Session Markov_Models

Theory Markov_Models_Auxiliary

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Auxiliary Theory›

text ‹Parts of it should be moved to the Isabelle repository›

theory Markov_Models_Auxiliary
imports
  "HOL-Probability.Probability"
  "HOL-Library.Rewrite"
  "HOL-Library.Linear_Temporal_Logic_on_Streams"
  Coinductive.Coinductive_Stream
  Coinductive.Coinductive_Nat
begin

lemma lfp_upperbound: "(y. x  f y)  x  lfp f"
  unfolding lfp_def by (intro Inf_greatest) (auto intro: order_trans)

(* ?? *)
lemma lfp_arg: "(λt. lfp (F t)) = lfp (λx t. F t (x t))"
  apply (auto simp: lfp_def le_fun_def fun_eq_iff intro!: Inf_eqI Inf_greatest)
  subgoal for x y
    by (rule INF_lower2[of "top(x := y)"]) auto
  done

lemma lfp_pair: "lfp (λf (a, b). F (λa b. f (a, b)) a b) (a, b) = lfp F a b"
  unfolding lfp_def
  by (auto intro!: INF_eq simp: le_fun_def)
     (auto intro!: exI[of _ "λ(a, b). x a b" for x])

lemma all_Suc_split: "(i. P i)  (P 0  (i. P (Suc i)))"
  using nat_induct by auto

definition "with P f d = (if x. P x then f (SOME x. P x) else d)"

lemma withI[case_names default exists]:
  "((x. ¬ P x)  Q d)  (x. P x  Q (f x))  Q (with P f d)"
  unfolding with_def by (auto intro: someI2)

context order
begin

definition
  "maximal f S = {xS. yS. f y  f x}"

lemma maximalI: "x  S  (y. y  S  f y  f x)  x  maximal f S"
  by (simp add: maximal_def)

lemma maximalI_trans: "x  maximal f S  f x  f y  y  S  y  maximal f S"
  unfolding maximal_def by (blast intro: antisym order_trans)

lemma maximalD1: "x  maximal f S  x  S"
  by (simp add: maximal_def)

lemma maximalD2: "x  maximal f S  y  S  f y  f x"
  by (simp add: maximal_def)

lemma maximal_inject: "x  maximal f S  y  maximal f S  f x = f y"
  by (rule order.antisym) (simp_all add: maximal_def)

lemma maximal_empty[simp]: "maximal f {} = {}"
  by (simp add: maximal_def)

lemma maximal_singleton[simp]: "maximal f {x} = {x}"
  by (auto simp add: maximal_def)

lemma maximal_in_S: "maximal f S  S"
  by (auto simp: maximal_def)

end

context linorder
begin

lemma maximal_ne:
  assumes "finite S" "S  {}"
  shows "maximal f S  {}"
  using assms
proof (induct rule: finite_ne_induct)
  case (insert s S)
  show ?case
  proof cases
    assume "xS. f x  f s"
    with insert have "s  maximal f (insert s S)"
      by (auto intro!: maximalI)
    then show ?thesis
      by auto
  next
    assume "¬ (xS. f x  f s)"
    then have "maximal f (insert s S) = maximal f S"
      by (auto simp: maximal_def)
    with insert show ?thesis
      by auto
  qed
qed simp

end

lemma mono_les:
  fixes s S N and l1 l2 :: "'a  real" and K :: "'a  'a pmf"
  defines "Δ x  l2 x - l1 x"
  assumes s: "s  S" and S: "(sS. set_pmf (K s))  S  N"
  assumes int_l1[simp]: "s. s  S  integrable (K s) l1"
  assumes int_l2[simp]: "s. s  S  integrable (K s) l2"
  assumes to_N: "s. s  S  tN. (s, t)  (SIGMA s:UNIV. K s)*"
  assumes l1: "s. s  S  (t. l1 t K s) + c s  l1 s"
  assumes l2: "s. s  S  l2 s  (t. l2 t K s) + c s"
  assumes eq: "s. s  N  l2 s  l1 s"
  assumes finitary: "finite (Δ ` (SN))"
  shows "l2 s  l1 s"
proof -
  define M where "M = {sSN. tSN. Δ t  Δ s}"

  have [simp]: "s. sS  integrable (K s) Δ"
    by (simp add: Δ_def[abs_def])

  have M_unqiue: "s t. s  M  t  M  Δ s = Δ t"
    by (auto intro!: antisym simp: M_def)
  have M1: "s. s  M  s  S  N"
    by (auto simp: M_def)
  have M2: "s t. s  M  t  S  N  Δ t  Δ s"
    by (auto simp: M_def)
  have M3: "s t. s  M  t  S  N  t  M  Δ t < Δ s"
    by (auto simp: M_def less_le)

  have N: "sN. Δ s  0"
    using eq by (simp add: Δ_def)

  { fix s assume s: "s  M" "M  N = {}"
    then have "s  S - N"
      by (auto dest: M1)
    with to_N[of s] obtain t where "(s, t)  (SIGMA s:UNIV. K s)*" and "t  N"
      by (auto simp: M_def)
    from this(1) s  M have "Δ s  0"
    proof (induction rule: converse_rtrancl_induct)
      case (step s s')
      then have s: "s  M" "s  S" "s  N" and s': "s'  S  N" "s'  K s"
        using S M  N = {} by (auto dest: M1)
      have "s'  M"
      proof (rule ccontr)
        assume "s'  M"
        with s  S s' s  M
        have "0 < pmf (K s) s'" "Δ s' < Δ s"
          by (auto intro: M2 M3 pmf_positive)

        have "Δ s  ((t. l2 t K s) + c s) - ((t. l1 t K s) + c s)"
          unfolding Δ_def using s  S s  N by (intro diff_mono l1 l2) auto
        then have "Δ s  (s'. Δ s' K s)"
          using s  S by (simp add: Δ_def)
        also have " < (s'. Δ s K s)"
          using s'  K s Δ s' < Δ s sS S sM
          by (intro measure_pmf.integral_less_AE[where A="{s'}"])
             (auto simp: emeasure_measure_pmf_finite AE_measure_pmf_iff set_pmf_iff[symmetric]
                   intro!: M2)
        finally show False
          using measure_pmf.prob_space[of "K s"] by simp
      qed
      with step.IH tN N have "Δ s'  0" "s'  M"
        by auto
      with sS show "Δ s  0"
        by (force simp: M_def)
    qed (insert N tN, auto) }

  show ?thesis
  proof cases
    assume "M  N = {}"
    have "Max (Δ`(SN))  Δ`(SN)"
      using s  S by (intro Max_in finitary) auto
    then obtain t where "t  S  N" "Δ t = Max (Δ`(SN))"
      unfolding image_iff by metis
    then have "t  M"
      by (auto simp: M_def finitary intro!: Max_ge)
    have "Δ s  Δ t"
      using tM sS by (auto dest: M2)
    also have "Δ t  0"
      using tM M  N = {} by fact
    finally show ?thesis
      by (simp add: Δ_def)
  next
    assume "M  N  {}"
    then obtain t where "t  M" "t  N" by auto
    with N sS have "Δ s  0"
      by (intro order_trans[of "Δ s" "Δ t" 0]) (auto simp: M_def)
    then show ?thesis
      by (simp add: Δ_def)
  qed
qed

lemma unique_les:
  fixes s S N and l1 l2 :: "'a  real" and K :: "'a  'a pmf"
  defines "Δ x  l2 x - l1 x"
  assumes s: "s  S" and S: "(sS. set_pmf (K s))  S  N"
  assumes "s. s  S  integrable (K s) l1"
  assumes "s. s  S  integrable (K s) l2"
  assumes "s. s  S  tN. (s, t)  (SIGMA s:UNIV. K s)*"
  assumes "s. s  S  l1 s = (t. l1 t K s) + c s"
  assumes "s. s  S  l2 s = (t. l2 t K s) + c s"
  assumes "s. s  N  l2 s = l1 s"
  assumes 1: "finite (Δ ` (SN))"
  shows "l2 s = l1 s"
proof -
  have "finite ((λx. l2 x - l1 x) ` (SN))"
    using 1 by (auto simp: Δ_def[abs_def])
  moreover then have "finite (uminus ` (λx. l2 x - l1 x) ` (SN))"
    by auto
  ultimately show ?thesis
    using assms
    by (intro antisym mono_les[of s S K N l2 l1 c] mono_les[of s S K N l1 l2 c])
       (auto simp: image_comp comp_def)
qed

lemma inf_continuous_suntil_disj[order_continuous_intros]:
  assumes Q: "inf_continuous Q"
  assumes disj: "x ω. ¬ (P ω  Q x ω)"
  shows "inf_continuous (λx. P suntil Q x)"
  unfolding inf_continuous_def
proof (safe intro!: ext)
  fix M ω i assume "(P suntil Q (i. M i)) ω" "decseq M" then show "(P suntil Q (M i)) ω"
    unfolding inf_continuousD[OF Q ‹decseq M] by induction (auto intro: suntil.intros)
next
  fix M ω assume *: "(i. P suntil Q (M i)) ω" "decseq M"
  then have "(P suntil Q (M 0)) ω"
    by auto
  from this * show "(P suntil Q (i. M i)) ω"
    unfolding inf_continuousD[OF Q ‹decseq M]
  proof induction
    case (base ω) with disj[of ω "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
  next
    case (step ω) with disj[of ω "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
  qed
qed

lemma inf_continuous_nxt[order_continuous_intros]: "inf_continuous P  inf_continuous (λx. nxt (P x) ω)"
  by (auto simp: inf_continuous_def image_comp)

lemma sup_continuous_nxt[order_continuous_intros]: "sup_continuous P  sup_continuous (λx. nxt (P x) ω)"
  by (auto simp: sup_continuous_def image_comp)

lemma mcont_ennreal_of_enat: "mcont Sup (≤) Sup (≤) ennreal_of_enat"
  by (auto intro!: mcontI monotoneI contI ennreal_of_enat_Sup)

lemma mcont2mcont_ennreal_of_enat[cont_intro]:
  "mcont lub ord Sup (≤) f  mcont lub ord Sup (≤) (λx. ennreal_of_enat (f x))"
  by (auto intro: ccpo.mcont2mcont[OF complete_lattice_ccpo'] mcont_ennreal_of_enat)

declare stream.exhaust[cases type: stream]

lemma scount_eq_emeasure: "scount P ω = emeasure (count_space UNIV) {i. P (sdrop i ω)}"
proof cases
  assume "alw (ev P) ω"
  moreover then have "infinite {i. P (sdrop i ω)}"
    using infinite_iff_alw_ev[of P ω] by simp
  ultimately show ?thesis
    by (simp add: scount_infinite_iff[symmetric])
next
  assume "¬ alw (ev P) ω"
  moreover then have "finite {i. P (sdrop i ω)}"
    using infinite_iff_alw_ev[of P ω] by simp
  ultimately show ?thesis
    by (simp add: not_alw_iff not_ev_iff scount_eq_card)
qed

lemma measurable_scount[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) P"
  shows "scount P  measurable (stream_space M) (count_space UNIV)"
  unfolding scount_eq[abs_def] by measurable

lemma measurable_sfirst2:
  assumes [measurable]: "Measurable.pred (N M stream_space M) (λ(x, ω). P x ω)"
  shows "(λ(x, ω). sfirst (P x) ω)  measurable (N M  stream_space M) (count_space UNIV)"
  apply (coinduction rule: measurable_enat_coinduct)
  apply simp
  apply (rule exI[of _ "λx. 0"])
  apply (rule exI[of _ "λ(x, ω). (x, stl ω)"])
  apply (rule exI[of _ "λ(x, ω). P x ω"])
  apply (subst sfirst.simps[abs_def])
  apply (simp add: fun_eq_iff)
  done

lemma measurable_sfirst2'[measurable (raw)]:
  assumes [measurable (raw)]: "f  N M stream_space M" "Measurable.pred (N M stream_space M) (λx. P (fst x) (snd x))"
  shows "(λx. sfirst (P x) (f x))  measurable N (count_space UNIV)"
  using measurable_sfirst2[measurable] by measurable

lemma measurable_sfirst[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) P"
  shows "sfirst P  measurable (stream_space M) (count_space UNIV)"
  by measurable

lemma measurable_epred[measurable]: "epred  count_space UNIV M count_space UNIV"
  by (rule measurable_count_space)

lemma nn_integral_stretch:
  "f  borel M borel  c  0  (+x. f (c * x) lborel) = (1 / ¦c¦::real) * (+x. f x lborel)"
  using nn_integral_real_affine[of f c 0] by (simp add: mult.assoc[symmetric] ennreal_mult[symmetric])

lemma prod_sum_distrib:
  fixes f g :: "'a  'b  'c::comm_semiring_1"
  assumes "finite I" shows "(i. i  I  finite (J i))  (iI. jJ i. f i j) = (mPiE I J. iI. f i (m i))"
  using ‹finite I
proof induction
  case (insert i I) then show ?case
    by (auto simp: PiE_insert_eq finite_PiE sum.reindex inj_combinator sum.swap[of _ "PiE I J"]
                   sum_cartesian_product' sum_distrib_left sum_distrib_right
             intro!: sum.cong prod.cong arg_cong[where f="(*) x" for x])
qed simp

lemma prod_add_distrib:
  fixes f g :: "'a  'b::comm_semiring_1"
  assumes "finite I" shows "(iI. f i + g i) = (JPow I. (iJ. f i) * (iI - J. g i))"
proof -
  have "(iI. f i + g i) = (iI. b{True, False}. if b then f i else g i)"
    by simp
  also have " = (mI E {True, False}. iI. if m i then f i else g i)"
    using ‹finite I by (rule prod_sum_distrib) simp
  also have " = (JPow I. (iJ. f i) * (iI - J. g i))"
    by (rule sum.reindex_bij_witness[where i="λJ. λiI. iJ" and j="λm. {iI. m i}"])
       (auto simp: fun_eq_iff prod.If_cases ‹finite I intro!: arg_cong2[where f="(*)"] prod.cong)
  finally show ?thesis .
qed

subclass (in linordered_nonzero_semiring) ordered_semiring_0
  proof qed

lemma (in linordered_nonzero_semiring) prod_nonneg: "(aA. 0  f a)  0  prod f A"
  by (induct A rule: infinite_finite_induct) simp_all

lemma (in linordered_nonzero_semiring) prod_mono:
  "iA. 0  f i  f i  g i  prod f A  prod g A"
  by (induct A rule: infinite_finite_induct) (auto intro!: prod_nonneg mult_mono)

lemma (in linordered_nonzero_semiring) prod_mono2:
  assumes "finite J" "I  J" "i. i  I  0  g i  g i  f i" "(i. i  J - I  1  f i)"
  shows "prod g I  prod f J"
proof -
  have "prod g I = (iJ. if i  I then g i else 1)"
    using ‹finite J I  J by (simp add: prod.If_cases Int_absorb1)
  also have "  prod f J"
    using assms by (intro prod_mono) auto
  finally show ?thesis .
qed

lemma (in linordered_nonzero_semiring) prod_mono3:
  assumes "finite J" "I  J" "i. i  J  0  g i" "i. i  I  g i  f i" "(i. i  J - I  g i  1)"
  shows "prod g J  prod f I"
proof -
  have "prod g J  (iJ. if i  I then f i else 1)"
    using assms by (intro prod_mono) auto
  also have " = prod f I"
    using ‹finite J I  J by (simp add: prod.If_cases Int_absorb1)
  finally show ?thesis .
qed

lemma (in linordered_nonzero_semiring) one_le_prod: "(i. i  I  1  f i)  1  prod f I"
proof (induction I rule: infinite_finite_induct)
  case (insert i I) then show ?case
    using mult_mono[of 1 "f i" 1 "prod f I"]
    by (auto intro: order_trans[OF zero_le_one])
qed auto

lemma sum_plus_one_le_prod_plus_one:
  fixes p :: "'a  'b::linordered_nonzero_semiring"
  assumes "i. i  I  0  p i"
  shows "(iI. p i) + 1  (iI. p i + 1)"
proof cases
  assume [simp]: "finite I"
  with assms have [simp]: "J  I  0  prod p J" for J
    by (intro prod_nonneg) auto
  have "1 + (iI. p i) = (Jinsert {} ((λx. {x})`I). (iJ. p i) * (iI - J. 1))"
    by (subst sum.insert) (auto simp: sum.reindex)
  also have "  (JPow I. (iJ. p i) * (iI - J. 1))"
    using assms by (intro sum_mono2) auto
  finally show ?thesis
    by (subst prod_add_distrib) (auto simp: add.commute)
qed simp

lemma summable_iff_convergent_prod:
  fixes p :: "nat  real" assumes p: "i. 0  p i"
  shows "summable p  convergent (λn. i<n. p i + 1)"
  unfolding summable_iff_convergent
proof
  assume "convergent (λn. i<n. p i + 1)"
  then obtain x where x: "(λn. i<n. p i + 1)  x"
    by (auto simp: convergent_def)
  then have "1  x"
    by (rule tendsto_lowerbound) (auto intro!: always_eventually one_le_prod p)

  have "convergent (λn. 1 + (i<n. p i))"
  proof (intro Bseq_mono_convergent BseqI allI)
    show "0 < x" using 1  x by auto
  next
    fix n
    have "norm ((i<n. p i) + 1)  (i<n. p i + 1)"
      using p by (simp add: sum_nonneg sum_plus_one_le_prod_plus_one p)
    also have "  x"
      using assms
      by (intro tendsto_lowerbound[OF x])
          (auto simp: eventually_sequentially intro!: exI[of _ n] prod_mono2)
    finally show "norm (1 + sum p {..<n})  x"
      by (simp add: add.commute)
  qed (insert p, auto intro!: sum_mono2)
  then show "convergent (λn. i<n. p i)"
    unfolding convergent_add_const_iff .
next
  assume "convergent (λn. i<n. p i)"
  then obtain x where x: "(λn. exp (i<n. p i))  exp x"
    by (force simp: convergent_def intro!: tendsto_exp)
  show "convergent (λn. i<n. p i + 1)"
  proof (intro Bseq_mono_convergent BseqI allI)
    show "0 < exp x" by simp
  next
    fix n
    have "norm (i<n. p i + 1)  exp (i<n. p i)"
      using p exp_ge_add_one_self[of "p _"] by (auto simp add: prod_nonneg exp_sum add.commute intro!: prod_mono)
    also have "  exp x"
      using p
      by (intro tendsto_lowerbound[OF x]) (auto simp: eventually_sequentially intro!: sum_mono2 )
    finally show "norm (i<n. p i + 1)  exp x" .
  qed (insert p, auto intro!: prod_mono2)
qed

primrec eexp :: "ereal  ennreal"
  where
    "eexp MInfty = 0"
  | "eexp (ereal r) = ennreal (exp r)"
  | "eexp PInfty = top"

lemma
  shows eexp_minus_infty[simp]: "eexp (-) = 0"
    and eexp_infty[simp]: "eexp  = top"
  using eexp.simps by simp_all

lemma eexp_0[simp]: "eexp 0 = 1"
  by (simp add: zero_ereal_def)

lemma eexp_inj[simp]: "eexp x = eexp y  x = y"
  by (cases x; cases y; simp)

lemma eexp_mono[simp]: "eexp x  eexp y  x  y"
  by (cases x; cases y; simp add: top_unique)

lemma eexp_strict_mono[simp]: "eexp x < eexp y  x < y"
  by (simp add: less_le)

lemma exp_eq_0_iff[simp]: "eexp x = 0  x = -"
  using eexp_inj[of x "-"] unfolding eexp_minus_infty .

lemma eexp_surj: "range eexp = UNIV"
proof -
  have part: "UNIV = {0}  {0 <..< top}  {top::ennreal}"
    by (auto simp: less_top)
  show ?thesis
    unfolding part
    by (force simp: image_iff less_top less_top_ennreal intro!: eexp.simps[symmetric] eexp.simps dest: exp_total)
qed

lemma continuous_on_eexp': "continuous_on UNIV eexp"
  by (rule continuous_onI_mono) (auto simp: eexp_surj)

lemma continuous_on_eexp[continuous_intros]: "continuous_on A f  continuous_on A (λx. eexp (f x))"
  by (rule continuous_on_compose2[OF continuous_on_eexp']) auto

lemma tendsto_eexp[tendsto_intros]: "(f  x) F  ((λx. eexp (f x))  eexp x) F"
  by (rule continuous_on_tendsto_compose[OF continuous_on_eexp']) auto

lemma measurable_eexp[measurable]: "eexp  borel M borel"
  using continuous_on_eexp' by (rule borel_measurable_continuous_onI)

lemma eexp_add: "¬ ((x =   y = -)  (x = -  y = ))  eexp (x + y) = eexp x * eexp y"
  by (cases x; cases y; simp add: exp_add ennreal_mult ennreal_top_mult ennreal_mult_top)

lemma sum_Pinfty:
  fixes f :: "'a  ereal"
  shows "sum f I =   (finite I  (iI. f i = ))"
  by (induction I rule: infinite_finite_induct) auto

lemma sum_Minfty:
  fixes f :: "'a  ereal"
  shows "sum f I = -  (finite I  ¬ (iI. f i = )  (iI. f i = -))"
  by (induction I rule: infinite_finite_induct)
     (auto simp: sum_Pinfty)

lemma eexp_sum: "¬ (iI. jI. f i = -  f j = )  eexp (iI. f i) = (iI. eexp (f i))"
proof (induction I rule: infinite_finite_induct)
  case (insert i I)
  have "eexp (sum f (insert i I)) = eexp (f i) * eexp (sum f I)"
    using insert.prems insert.hyps by (auto simp: sum_Pinfty sum_Minfty intro!: eexp_add)
  then show ?case
    using insert by auto
qed simp_all

lemma eexp_suminf:
  assumes wf_f: "¬ {-, }  range f" and f: "summable f"
  shows "(λn. i<n. eexp (f i))  eexp (i. f i)"
proof -
  have "(λn. eexp (i<n. f i))  eexp (i. f i)"
    by (intro tendsto_eexp summable_LIMSEQ f)
  also have "(λn. eexp (i<n. f i)) = (λn. i<n. eexp (f i))"
    using wf_f by (auto simp: fun_eq_iff image_iff eq_commute intro!: eexp_sum)
  finally show ?thesis .
qed

lemma continuous_onI_antimono:
  fixes f :: "'a::linorder_topology  'b::{dense_order,linorder_topology}"
  assumes "open (f`A)"
    and mono: "x y. x  A  y  A  x  y  f y  f x"
  shows "continuous_on A f"
proof (rule continuous_on_generate_topology[OF open_generated_order], safe)
  have monoD: "x y. x  A  y  A  f y < f x  x < y"
    by (auto simp: not_le[symmetric] mono)
  have "x. x  A  f x < b  x < a" if a: "a  A" and fa: "f a < b" for a b
  proof -
    obtain y where "f a < y" "{f a ..< y}  f`A"
      using open_right[OF ‹open (f`A), of "f a" b] a fa
      by auto
    obtain z where z: "f a < z" "z < min b y"
      using dense[of "f a" "min b y"] f a < y f a < b by auto
    then obtain c where "z = f c" "c  A"
      using {f a ..< y}  f`A[THEN subsetD, of z] by (auto simp: less_imp_le)
    with a z show ?thesis
      by (auto intro!: exI[of _ c] simp: monoD)
  qed
  then show "C. open C  C  A = f -` {..<b}  A" for b
    by (intro exI[of _ "(x{xA. f x < b}. {x <..})"])
       (auto intro: le_less_trans[OF mono] less_imp_le)

  have "x. x  A  b < f x  x > a" if a: "a  A" and fa: "b < f a" for a b
  proof -
    note a fa
    moreover
    obtain y where "y < f a" "{y <.. f a}  f`A"
      using open_left[OF ‹open (f`A), of "f a" b]  a fa
      by auto
    then obtain z where z: "max b y < z" "z < f a"
      using dense[of "max b y" "f a"] y < f a b < f a by auto
    then obtain c where "z = f c" "c  A"
      using {y <.. f a}  f`A[THEN subsetD, of z] by (auto simp: less_imp_le)
    with a z show ?thesis
      by (auto intro!: exI[of _ c] simp: monoD)
  qed
  then show "C. open C  C  A = f -` {b <..}  A" for b
    by (intro exI[of _ "(x{xA. b < f x}. {..< x})"])
       (auto intro: less_le_trans[OF _ mono] less_imp_le)
qed

lemma minus_add_eq_ereal: "¬ ((a =   b = -)  (a = -  b = ))  - (a + b::ereal) = -a - b"
  by (cases a; cases b; simp)

lemma setsum_negf_ereal: "¬ {-, }  f`I  (iI. - f i) = - (iI. f i::ereal)"
  by (induction I rule: infinite_finite_induct)
     (auto simp: minus_add_eq_ereal sum_Minfty sum_Pinfty,
      (subst minus_add_eq_ereal; auto simp: sum_Pinfty sum_Minfty image_iff minus_ereal_def)+)

lemma convergent_minus_iff_ereal: "convergent (λx. - f x::ereal)  convergent f"
  unfolding convergent_def  by (metis ereal_uminus_uminus ereal_Lim_uminus)

lemma summable_minus_ereal: "¬ {-, }  range f  summable (λn. f n)  summable (λn. - f n::ereal)"
  unfolding summable_iff_convergent
  by (subst setsum_negf_ereal) (auto simp: convergent_minus_iff_ereal)

lemma (in product_prob_space) product_nn_integral_component:
  assumes "f  borel_measurable (M i)""i  I"
  shows "integralN (PiM I M) (λx. f (x i)) = integralN (M i) f"
proof -
  from assms show ?thesis
    apply (subst PiM_component[symmetric, OF i  I])
    apply (subst nn_integral_distr[OF measurable_component_singleton])
    apply simp_all
    done
qed

lemma ennreal_inverse_le[simp]: "inverse x  inverse y  y  (x::ennreal)"
  by (cases "0 < x"; cases x; cases "0 < y"; cases y; auto simp: top_unique inverse_ennreal)

lemma inverse_inverse_ennreal[simp]: "inverse (inverse x::ennreal) = x"
  by (cases "0 < x"; cases x; auto simp: inverse_ennreal)

lemma range_inverse_ennreal: "range inverse = (UNIV::ennreal set)"
proof -
  have "x. y = inverse x" for y :: ennreal
    by (intro exI[of _ "inverse y"]) simp
  then show ?thesis
    unfolding surj_def by auto
qed

lemma continuous_on_inverse_ennreal': "continuous_on (UNIV :: ennreal set) inverse"
  by (rule continuous_onI_antimono) (auto simp: range_inverse_ennreal)

lemma sums_minus_ereal: "¬ {- , }  f ` UNIV  (λn. - f n::ereal) sums x  f sums - x"
  unfolding sums_def
  apply (subst ereal_Lim_uminus)
  apply (subst (asm) setsum_negf_ereal)
  apply auto
  done

lemma suminf_minus_ereal: "¬ {- , }  f ` UNIV  summable f  (n. - f n :: ereal) = - suminf f"
  apply (rule sums_unique[symmetric])
  apply (rule sums_minus_ereal)
  apply (auto simp: ereal_uminus_eq_reorder)
  done

end

Theory Discrete_Time_Markov_Chain

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Discrete-Time Markov Chain›

theory Discrete_Time_Markov_Chain
  imports Markov_Models_Auxiliary
begin

text ‹

Markov chain with discrete time steps and discrete state space.

›

lemma sstart_eq': "sstart Ω (x # xs) = {ω. shd ω = x  stl ω  sstart Ω xs}"
  by (auto simp: sstart_eq)

lemma measure_eq_stream_space_coinduct[consumes 1, case_names left right cont]:
  assumes "R N M"
  assumes R_1: "N M. R N M  N  space (prob_algebra (stream_space (count_space UNIV)))"
    and R_2: "N M. R N M  M  space (prob_algebra (stream_space (count_space UNIV)))"
    and cont: "N M. R N M  N' M' p. (yset_pmf p. R (N' y) (M' y)) 
      (x. N' x  space (prob_algebra (stream_space (count_space UNIV))))  (x. M' x  space (prob_algebra (stream_space (count_space UNIV))))  
      N = (measure_pmf p  (λy. distr (N' y) (stream_space (count_space UNIV)) ((##) y))) 
      M = (measure_pmf p  (λy. distr (M' y) (stream_space (count_space UNIV)) ((##) y)))"
  shows "N = M"
proof -
  let ?S = "stream_space (count_space UNIV)"
  have "N M. R N M  (N' M' p. (yset_pmf p. R (N' y) (M' y)) 
      (x. N' x  space (prob_algebra ?S))  (x. M' x  space (prob_algebra ?S)) 
      N = (measure_pmf p  (λy. distr (N' y) ?S ((##) y))) 
      M = (measure_pmf p  (λy. distr (M' y) ?S ((##) y))))"
    using cont by auto
  then obtain n m p where
    p: "N M y. R N M  y  set_pmf (p N M)  R (n N M y) (m N M y)" and
    n: "N M x. R N M  n N M x  space (prob_algebra ?S)" and
    n_eq: "N M y. R N M  N = (measure_pmf (p N M)  (λy. distr (n N M y) ?S ((##) y)))" and
    m: "N M x. R N M  m N M x  space (prob_algebra ?S)" and
    m_eq: "N M y. R N M  M = (measure_pmf (p N M)  (λy. distr (m N M y) ?S ((##) y)))"
    unfolding choice_iff' choice_iff by blast

  define A where "A = (SIGMA nm:UNIV. (λx. (n (fst nm) (snd nm) x, m (fst nm) (snd nm) x)) ` p (fst nm) (snd nm))"
  have A_singleton: "A `` {nm} = (λx. (n (fst nm) (snd nm) x, m (fst nm) (snd nm) x)) ` p (fst nm) (snd nm)" for nm
    by (auto simp: A_def)

  have sets_n[measurable_cong, simp]: "sets (n N M y) = sets ?S" if "R N M" for N M y
    using n[OF that, of y] by (auto simp: space_prob_algebra)
  have sets_m[measurable_cong, simp]: "sets (m N M y) = sets ?S" if "R N M" for N M y
    using m[OF that, of y] by (auto simp: space_prob_algebra)
  have [simp]: "R N M  prob_space (n N M y)" for N M y
    using n[of N M y] by (auto simp: space_prob_algebra)
  have [simp]: "R N M  prob_space (m N M y)" for N M y
    using m[of N M y] by (auto simp: space_prob_algebra)
  have [measurable]: "R N M  n N M  count_space UNIV M subprob_algebra ?S" for N M
    by (rule measurable_prob_algebraD) (auto intro: n)
  have [measurable]: "R N M  m N M  count_space UNIV M subprob_algebra ?S" for N M
    by (rule measurable_prob_algebraD) (auto intro: m)

  define n' where "n' N M y = distr (n N M y) ?S ((##) y)" for N M y
  define m' where "m' N M y = distr (m N M y) ?S ((##) y)" for N M y
  have n'_eq: "R N M  N = (measure_pmf (p N M)  n' N M)" for N M unfolding n'_def by (rule n_eq)
  have m'_eq: "R N M  M = (measure_pmf (p N M)  m' N M)" for N M unfolding m'_def by (rule m_eq)
  have [measurable]: "R N M  n' N M  count_space UNIV M subprob_algebra ?S" for N M
    unfolding n'_def by (rule measurable_distr2[where M="?S"]) measurable
  have [measurable]: "R N M  m' N M  count_space UNIV M subprob_algebra ?S" for N M
    unfolding m'_def by (rule measurable_distr2[where M="?S"]) measurable

  have n'_shd: "R N M  distr (n' N M y) (count_space UNIV) shd = measure_pmf (return_pmf y)" for N M y
    unfolding n'_def by (subst distr_distr) (auto simp: comp_def prob_space.distr_const return_pmf.rep_eq)
  have m'_shd: "R N M  distr (m' N M y) (count_space UNIV) shd = measure_pmf (return_pmf y)" for N M y
    unfolding m'_def by (subst distr_distr) (auto simp: comp_def prob_space.distr_const return_pmf.rep_eq)
  have n'_stl: "R N M  distr (n' N M y) ?S stl = n N M y" for N M y
    unfolding n'_def by (subst distr_distr) (auto simp: comp_def distr_id2)
  have m'_stl: "R N M  distr (m' N M y) ?S stl = m N M y" for N M y
    unfolding m'_def by (subst distr_distr) (auto simp: comp_def distr_id2)

  define F where "F = (A* `` {(N, M)})"
  have "countable F"
    unfolding F_def
    apply (intro countable_rtrancl countable_insert[of _ "(N, M)"] countable_empty)
    apply (rule countable_Image)
     apply (auto simp: A_singleton)
    done
  have F_NM[simp]: "(N, M)  F" unfolding F_def by auto
  have R_F[simp]: "R N' M'" if "(N', M')  F" for N' M'
  proof -
    have "((N, M), (N', M'))  A*" using that by (auto simp: F_def)
    then show "R N' M'"
      by (induction p=="(N', M')" arbitrary: N' M' rule: rtrancl_induct) (auto simp: R N M A_def p)
  qed
  have nm_F: "(n N' M' y, m N' M' y)  F" if "y  p N' M'" "(N', M')  F" for N' M' y
  proof -
    have *: "((N, M), (N', M'))  A*" using that by (auto simp: F_def)
    with that show ?thesis
      apply (simp add: F_def)
      apply (intro rtrancl.rtrancl_into_rtrancl[OF *])
      apply (auto simp: A_def)
      done
  qed

  define Ω where "Ω = ((n, m)F. set_pmf (p n m))"
  have [measurable]: "Ω  sets (count_space UNIV)" by auto
  have in_Ω: "(N, M)  F  y  p N M  y  Ω" for N M y
    by (auto simp: Ω_def Bex_def)

  show ?thesis
  proof (intro stream_space_eq_sstart)
    from ‹countable F show "countable Ω"
      by (auto simp add: Ω_def)
    show "prob_space N" "prob_space M" "sets N = sets ?S" "sets M = sets ?S"
      using R_1[OF R N M] R_2[OF R N M] by (auto simp add: space_prob_algebra)
    have "N M. (N, M)  F  AE x in N. x !! i  Ω" for i
    proof (induction i)
      case 0 note NM = 0[THEN R_F, simp] show ?case
        apply (subst n'_eq[OF NM])
        apply (subst AE_bind[where B="?S"])
          apply measurable
        apply (auto intro!: AE_distrD[where f=shd and M'="count_space UNIV"]
                    simp: AE_measure_pmf_iff n[OF NM] n'_shd in_Ω[OF 0] cong: AE_cong_simp)
        done
    next
      case (Suc i) note NM = Suc(2)[THEN R_F, simp]
      show ?case
        apply (subst n'_eq[OF NM])
        apply (subst AE_bind[where B="?S"])
          apply measurable
        apply (auto intro!: AE_distrD[where f=stl and M'="?S"] Suc(1)[OF nm_F] Suc(2)
          simp: AE_measure_pmf_iff n'_stl cong: AE_cong_simp)
        done
    qed
    then have AE_N: "N M. (N, M)  F  AE x in N. x  streams Ω"
      unfolding streams_iff_snth AE_all_countable by auto
    then show "AE x in N. x  streams Ω" by (blast intro: F_NM)

    have "N M. (N, M)  F  AE x in M. x !! i  Ω" for i
    proof (induction i arbitrary: N M)
      case 0 note NM = 0[THEN R_F, simp] show ?case
        apply (subst m'_eq[OF NM])
        apply (subst AE_bind[where B="?S"])
          apply measurable
        apply (auto intro!: AE_distrD[where f=shd and M'="count_space UNIV"]
                    simp: AE_measure_pmf_iff m[OF NM] m'_shd in_Ω[OF 0] cong: AE_cong_simp)
        done
    next
      case (Suc i) note NM = Suc(2)[THEN R_F, simp]
      show ?case
        apply (subst m'_eq[OF NM])
        apply (subst AE_bind[where B="?S"])
          apply measurable
        apply (auto intro!: AE_distrD[where f=stl and M'="?S"] Suc(1)[OF nm_F] Suc(2)
          simp: AE_measure_pmf_iff m'_stl cong: AE_cong_simp)
        done
    qed
    then have AE_M: "N M. (N, M)  F  AE x in M. x  streams Ω"
      unfolding streams_iff_snth AE_all_countable by auto
    then show "AE x in M. x  streams Ω" by (blast intro: F_NM)

    fix xs assume "xs  lists Ω"
    with (N, M)  F show "emeasure N (sstart Ω xs) = emeasure M (sstart Ω xs)"
    proof (induction xs arbitrary: N M)
      case Nil
      have "prob_space N" "prob_space M" "sets N = sets ?S" "sets M = sets ?S"
        using R_1[OF R_F[OF Nil(1)]] R_2[OF R_F[OF Nil(1)]] by (auto simp add: space_prob_algebra)
      have "emeasure N (streams Ω) = 1"
        by (rule prob_space.emeasure_eq_1_AE[OF ‹prob_space N _ AE_N[OF Nil(1)]])
           (auto simp add: ‹sets N = sets ?S intro!: streams_sets)
      moreover have "emeasure M (streams Ω) = 1"
        by (rule prob_space.emeasure_eq_1_AE[OF ‹prob_space M _ AE_M[OF Nil(1)]])
           (auto simp add: ‹sets M = sets ?S intro!: streams_sets)
      ultimately show ?case by simp
    next
      case (Cons x xs)
      note NM = Cons(2)[THEN R_F, simp]
      have *: "(##) y -` sstart Ω (x # xs) = (if x = y then sstart Ω xs else {})" for y
        by auto
      show ?case
        apply (subst n'_eq[OF NM])
        apply (subst (3) m'_eq[OF NM])
        apply (subst emeasure_bind[OF _ _ sstart_sets])
          apply simp []
         apply measurable []
        apply (subst emeasure_bind[OF _ _ sstart_sets])
          apply simp []
         apply measurable []
        apply (intro nn_integral_cong_AE AE_pmfI)
        apply (subst n'_def)
        apply (subst m'_def)
        using Cons(3)
        apply (auto intro!: Cons nm_F
          simp add: emeasure_distr sets_eq_imp_space_eq[OF sets_n] sets_eq_imp_space_eq[OF sets_m]
                    space_stream_space *)
        done
    qed
  qed
qed

subsection ‹Discrete Markov Kernel›

locale MC_syntax =
  fixes K :: "'s  's pmf"
begin

abbreviation acc :: "('s × 's) set" where
  "acc  (SIGMA s:UNIV. K s)*"

abbreviation acc_on :: "'s set  ('s × 's) set" where
  "acc_on S  (SIGMA s:UNIV. K s  S)*"

lemma countable_reachable: "countable (acc `` {s})"
  by (auto intro!: countable_rtrancl countable_set_pmf simp: Sigma_Image)

lemma countable_acc: "countable X  countable (acc `` X)"
  apply (rule countable_Image)
  apply (rule countable_reachable)
  apply assumption
  done

context
  notes [[inductive_internals]]
begin

coinductive enabled where
  "enabled (shd ω) (stl ω)  shd ω  K s  enabled s ω"

end

lemma alw_enabled: "enabled (shd ω) (stl ω)  alw (λω. enabled (shd ω) (stl ω)) ω"
  by (coinduction arbitrary: ω rule: alw_coinduct) (auto elim: enabled.cases)

abbreviation "S  stream_space (count_space UNIV)"

lemma in_S [measurable (raw)]: "x  space S"
  by (simp add: space_stream_space)

inductive_simps enabled_iff: "enabled s ω"

lemma enabled_Stream: "enabled x (y ## ω)  y  K x  enabled y ω"
  by (subst enabled_iff)  auto

lemma measurable_enabled[measurable]:
  "Measurable.pred (stream_space (count_space UNIV)) (enabled s)" (is "Measurable.pred ?S _")
  unfolding enabled_def
proof (coinduction arbitrary: s rule: measurable_gfp2_coinduct)
  case (step A s)
  then have [measurable]: "t. Measurable.pred ?S (A t)" by auto
  have *: "x. (ω t. s = t  x = ω  A (shd ω) (stl ω)  shd ω  set_pmf (K t)) 
    (tK s. A t (stl x)  t = shd x)"
    by auto
  note countable_set_pmf[simp]
  show ?case
    unfolding * by measurable
qed (auto simp: inf_continuous_def)

lemma enabled_iff_snth: "enabled s ω  (i. ω !! i  K ((s ## ω) !! i))"
proof safe
  fix i assume "enabled s ω" then show "ω !! i  K ((s ## ω) !! i)"
    by (induct i arbitrary: s ω)
       (force elim: enabled.cases)+
next
  assume "i. ω !! i  set_pmf (K ((s ## ω) !! i))" then show "enabled s ω"
    by (coinduction arbitrary: s ω)
       (auto elim: allE[of _ "Suc i" for i] allE[of _ 0])
qed

primcorec force_enabled where
  "force_enabled x ω =
    (let y = if shd ω  K x then shd ω else (SOME y. y  K x) in y ## force_enabled y (stl ω))"

lemma force_enabled_in_set_pmf[simp, intro]: "shd (force_enabled x ω)  K x"
  by (auto simp: some_in_eq set_pmf_not_empty)

lemma enabled_force_enabled: "enabled x (force_enabled x ω)"
  by (coinduction arbitrary: x ω) (auto simp: some_in_eq set_pmf_not_empty)

lemma force_enabled: "enabled x ω  force_enabled x ω = ω"
  by (coinduction arbitrary: x ω) (auto elim: enabled.cases)

lemma Ex_enabled: "ω. enabled x ω"
  by (rule exI[of _ "force_enabled x undefined"] enabled_force_enabled)+

lemma measurable_force_enabled: "force_enabled x  measurable S S"
proof (rule measurable_stream_space2)
  fix n show "(λω. force_enabled x ω !! n)  measurable S (count_space UNIV)"
  proof (induction n arbitrary: x)
    case (Suc n) show ?case
      apply simp
      apply (rule measurable_compose_countable'[OF measurable_compose[OF measurable_stl Suc], where I="set_pmf (K x)"])
      apply (rule measurable_compose[OF measurable_shd])
      apply (auto simp: countable_set_pmf some_in_eq set_pmf_not_empty)
      done
  qed (auto intro!: measurable_compose[OF measurable_shd])
qed

abbreviation "D  stream_space (ΠM sUNIV. K s)"

lemma sets_D: "sets D = sets (stream_space (ΠM sUNIV. count_space UNIV))"
  by (intro sets_stream_space_cong sets_PiM_cong) simp_all

lemma space_D: "space D = space (stream_space (ΠM sUNIV. count_space UNIV))"
  using sets_eq_imp_space_eq[OF sets_D] .

lemma measurable_D_D: "measurable D D =
    measurable (stream_space (ΠM sUNIV. count_space UNIV)) (stream_space (ΠM sUNIV. count_space UNIV))"
  by (simp add: measurable_def space_D sets_D)

primcorec walk :: "'s  ('s  's) stream  's stream" where
  "shd (walk s ω) = (if shd ω s  K s then shd ω s else (SOME t. t  K s))"
| "stl (walk s ω) = walk (if shd ω s  K s then shd ω s else (SOME t. t  K s)) (stl ω)"

lemma enabled_walk: "enabled s (walk s ω)"
  by (coinduction arbitrary: s ω) (auto simp: some_in_eq set_pmf_not_empty)

lemma measurable_walk[measurable]: "walk s  measurable D S"
proof -
  note measurable_compose[OF measurable_snth, intro!]
  note measurable_compose[OF measurable_component_singleton, intro!]
  note if_weak_cong[cong del]
  note measurable_g = measurable_compose_countable'[OF _ _ countable_reachable]

  define n :: nat where "n = 0"
  define g where "g = (λ_::('s  's) stream. s)"
  then have "g  measurable D (count_space (acc `` {s}))"
    by auto
  then have "(λx. walk (g x) (sdrop n x))  measurable D S"
  proof (coinduction arbitrary: g n rule: measurable_stream_coinduct)
    case (shd g) show ?case
      by (fastforce intro: measurable_g[OF _ shd])
  next
    case (stl g) show ?case
      by (fastforce simp add: sdrop.simps[symmetric] some_in_eq set_pmf_not_empty
                    simp del: sdrop.simps intro: rtrancl_into_rtrancl measurable_g[OF _ stl])
  qed
  then show ?thesis
    by (simp add: g_def n_def)
qed

subsection ‹Trace Space for Discrete-Time Markov Chains›

definition T :: "'s  's stream measure" where
  "T s = distr (stream_space (ΠM sUNIV. K s)) S (walk s)"

lemma space_T[simp]: "space (T s) = space S"
  by (simp add: T_def)

lemma sets_T[simp, measurable_cong]: "sets (T s) = sets S"
  by (simp add: T_def)

lemma measurable_T1[simp]: "measurable (T s) M = measurable S M"
  by (intro measurable_cong_sets) simp_all

lemma measurable_T2[simp]: "measurable M (T s) = measurable M S"
  by (intro measurable_cong_sets) simp_all

lemma in_measurable_T1[measurable (raw)]: "f  measurable S M  f  measurable (T s) M"
  by simp

lemma in_measurable_T2[measurable (raw)]: "f  measurable M S  f  measurable M (T s)"
  by simp

lemma AE_T_enabled: "AE ω in T s. enabled s ω"
  unfolding T_def by (simp add: AE_distr_iff enabled_walk)

sublocale T: prob_space "T s" for s
proof -
  interpret P: product_prob_space K UNIV ..
  interpret prob_space "stream_space (ΠM sUNIV. K s)"
    by (rule P.prob_space_stream_space)
  fix s show "prob_space (T s)"
    by (simp add: T_def prob_space_distr)
qed

lemma emeasure_T_const[simp]: "emeasure (T s) (space S) = 1"
  using T.emeasure_space_1[of s] by simp

lemma nn_integral_T:
  assumes f[measurable]: "f  borel_measurable S"
  shows "(+X. f X T s) = (+t. (+ω. f (t ## ω) T t) K s)"
proof -
  interpret product_prob_space K UNIV ..
  interpret D: prob_space "stream_space (ΠM sUNIV. K s)"
    by (rule prob_space_stream_space)

  have T: "f s. f  borel_measurable S  (+X. f X T s) = (+ω. f (walk s ω) D)"
    by (simp add: T_def nn_integral_distr)

  have "(+X. f X T s) = (+ω. f (walk s ω) D)"
    by (rule T) measurable
  also have " = (+d. +ω. f (walk s (d ## ω)) D ΠM iUNIV. K i)"
    by (simp add: P.nn_integral_stream_space)
  also have " = (+d. (+ω. f (d s ## walk (d s) ω) * indicator {t. t  K s} (d s) D) ΠM iUNIV. K i)"
    apply (rule nn_integral_cong_AE)
    apply (subst walk.ctr)
    apply (simp cong del: if_weak_cong)
    apply (intro UNIV_I AE_component)
    apply (auto simp: AE_measure_pmf_iff)
    done
  also have " = (+d. +ω. f (d s ## ω) * indicator (K s) (d s) T (d s) ΠM iUNIV. K i)"
    by (subst T) (simp_all split: split_indicator)
  also have " = (+t. +ω. f (t ## ω) * indicator (K s) t T t K s)"
    by (subst (2) PiM_component[symmetric]) (simp_all add: nn_integral_distr)
  also have " = (+t. +ω. f (t ## ω) T t K s)"
    by (rule nn_integral_cong_AE) (simp add: AE_measure_pmf_iff)
  finally show ?thesis .
qed

lemma nn_integral_T_gfp:
  fixes g
  defines "l  λf ω. g (shd ω) (f (stl ω))"
  assumes [measurable]: "case_prod g  borel_measurable (count_space UNIV M borel)"
  assumes cont_g[THEN inf_continuous_compose, order_continuous_intros]: "s. inf_continuous (g s)"
  assumes int_g: "f s. f  borel_measurable S  (+ω. g s (f ω) T s) = g s (+ω. f ω T s)"
  assumes bnd_g: "f s. g s f  b" "0  b" "b < "
  shows "(+ω. gfp l ω T s) = gfp (λf s. +t. g t (f t) K s) s"
proof (rule nn_integral_gfp)
  show "s. sets (T s) = sets S" "F. F  borel_measurable S  l F  borel_measurable S"
    by (auto simp: l_def)
  show "s. emeasure (T s) (space (T s))  0"
   by (rewrite T.emeasure_space_1) simp
  { fix s F
    have "integralN (T s) (l F)  (+x. b T s)"
      by (intro nn_integral_mono) (simp add: l_def bnd_g)
    also have " < "
      using bnd_g by simp
    finally show "integralN (T s) (l F) < " . }
  show "inf_continuous (λf s. + t. g t (f t) K s)"
  proof (intro order_continuous_intros)
    fix f s
    have "(+ t. g t (f t) K s)  (+ t. b K s)"
      by (intro nn_integral_mono bnd_g)
    also have " < "
      using bnd_g by simp
    finally show "(+ t. g t (f t) K s)  "
      by simp
  qed simp
next
  fix s and F :: "'s stream  ennreal" assume "F  borel_measurable S"
  then show "integralN (T s) (l F) = (+ t. g t (integralN (T t) F) K s) "
    by (rewrite nn_integral_T) (simp_all add: l_def int_g)
qed (auto intro!: order_continuous_intros simp: l_def)

lemma nn_integral_T_lfp:
  fixes g
  defines "l  λf ω. g (shd ω) (f (stl ω))"
  assumes [measurable]: "case_prod g  borel_measurable (count_space UNIV M borel)"
  assumes cont_g[THEN sup_continuous_compose, order_continuous_intros]: "s. sup_continuous (g s)"
  assumes int_g: "f s. f  borel_measurable S  (+ω. g s (f ω) T s) = g s (+ω. f ω T s)"
  shows "(+ω. lfp l ω T s) = lfp (λf s. +t. g t (f t) K s) s"
proof (rule nn_integral_lfp)
  show "s. sets (T s) = sets S" "F. F  borel_measurable S  l F  borel_measurable S"
    by (auto simp: l_def)
next
  fix s and F :: "'s stream  ennreal" assume "F  borel_measurable S"
  then show "integralN (T s) (l F) = (+ t. g t (integralN (T t) F) K s) "
    by (rewrite nn_integral_T) (simp_all add: l_def int_g)
qed (auto simp: l_def intro!: order_continuous_intros)

lemma emeasure_Collect_T:
  assumes f[measurable]: "Measurable.pred S P"
  shows "emeasure (T s) {xspace (T s). P x} = (+t. emeasure (T t) {xspace (T t). P (t ## x)} K s)"
  apply (subst (1 2) nn_integral_indicator[symmetric])
  apply simp
  apply simp
  apply (subst nn_integral_T)
  apply (auto intro!: nn_integral_cong simp add: space_stream_space indicator_def)
  done

lemma AE_T_iff:
  assumes [measurable]: "Measurable.pred S P"
  shows "(AE ω in T x. P ω)  (yK x. AE ω in T y. P (y ## ω))"
  by (simp add: AE_iff_nn_integral nn_integral_T[where s=x])
     (auto simp add: nn_integral_0_iff_AE AE_measure_pmf_iff split: split_indicator)

lemma AE_T_alw:
  assumes [measurable]: "Measurable.pred S P"
  assumes P: "s. (x, s)  acc  AE ω in T s. P ω"
  shows "AE ω in T x. alw P ω"
proof -
  define F where "F = (λp x. P x  p (stl x))"
  have [measurable]: "p. Measurable.pred S p  Measurable.pred S (F p)"
    by (auto simp: F_def)
  have "almost_everywhere (T s) ((F ^^ i) top)"
    if "(x, s)  acc" for i s
    using that
  proof (induction i arbitrary: s)
    case (Suc i) then show ?case
      apply simp
      apply (subst F_def)
      apply (simp add: P)
      apply (subst AE_T_iff)
      apply (measurable; simp)
      apply (auto dest: rtrancl_into_rtrancl)
      done
  qed simp
  then have "almost_everywhere (T x) (gfp F)"
    by (subst inf_continuous_gfp) (auto simp: inf_continuous_def AE_all_countable F_def)
  then show ?thesis
    by (simp add: alw_def F_def)
qed

lemma emeasure_suntil_disj:
  assumes [measurable]: "Measurable.pred S P"
  assumes *: "t. AE ω in T t. ¬ (P  (HLD X  nxt (HLD X suntil P))) ω"
  shows "emeasure (T s) {ωspace (T s). (HLD X suntil P) ω} =
    lfp (λF s. emeasure (T s) {ωspace (T s). P ω} + (+t. F t * indicator X t K s)) s"
  unfolding suntil_lfp
proof (rule emeasure_lfp[where s=s])
  fix F t assume [measurable]: "Measurable.pred (T s) F" and
    F: "F  lfp (λa b. P b  HLD X b  a (stl b))"
  have "emeasure (T t) {ω  space (T s). P ω  HLD X ω  F (stl ω)} =
    emeasure (T t) {ω  space (T t). P ω} + emeasure (T t) {ωspace (T t). HLD X ω  F (stl ω)}"
  proof (rule emeasure_add_AE)
    show "AE x in T t. ¬ (x  {ω  space (T t). P ω}  x  {ω  space (T t). HLD X ω  F (stl ω)})"
      using * by eventually_elim (insert F, auto simp: suntil_lfp[symmetric])
  qed auto
  also have "emeasure (T t) {ωspace (T t). HLD X ω  F (stl ω)} =
    (+t. emeasure (T t) {ω  space (T s). F ω} * indicator X t K t)"
    by (subst emeasure_Collect_T) (auto intro!: nn_integral_cong split: split_indicator)
  finally show "emeasure (T t) {ω  space (T s). P ω  HLD X ω  F (stl ω)} =
    emeasure (T t) {ω  space (T t). P ω} + (+ t. emeasure (T t) {ω  space (T s). F ω} * indicator X t K t)" .
qed (auto intro!: order_continuous_intros split: split_indicator)

lemma emeasure_HLD_nxt:
  assumes [measurable]: "Measurable.pred S P"
  shows "emeasure (T s) {ωspace (T s). (X  P) ω} =
    (+x. emeasure (T x) {ωspace (T x). P ω} * indicator X x K s)"
  by (subst emeasure_Collect_T)
     (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff split: split_indicator)

lemma emeasure_HLD:
  "emeasure (T s) {ωspace (T s). HLD X ω} = emeasure (K s) X"
  using emeasure_HLD_nxt[of "λω. True" s X] T.emeasure_space_1 by simp

lemma emeasure_suntil_HLD:
  assumes [measurable]: "Measurable.pred S P"
  shows "emeasure (T s) {xspace (T s). (not (HLD {t}) suntil (HLD {t} aand nxt P)) x} =
   emeasure (T s) {xspace (T s). ev (HLD {t}) x} * emeasure (T t) {xspace (T t). P x}"
proof -
  let ?P = "emeasure (T t) {ωspace (T t). P ω}"
  let ?F = "λQ F s. emeasure (T s) {ωspace (T s). Q ω} + (+t'. F t' * indicator (- {t}) t' K s)"
  have "emeasure (T s) {xspace (T s). (HLD (-{t}) suntil ({t}  P)) x} = lfp (?F ({t}  P)) s"
    by (rule emeasure_suntil_disj) (auto simp: HLD_iff)
  also have "lfp (?F ({t}  P)) = (λs. lfp (?F (HLD {t})) s * ?P)"
  proof (rule lfp_transfer[symmetric, where α="λx s. x s * emeasure (T t) {ωspace (T t). P ω}"])
    fix F show "(λs. ?F (HLD {t}) F s * ?P) = ?F ({t}  P) (λs. F s * ?P)"
      unfolding emeasure_HLD emeasure_HLD_nxt[OF assms] distrib_right
      by (auto simp: fun_eq_iff nn_integral_multc[symmetric]
               intro!: arg_cong2[where f="(+)"] nn_integral_cong ac_simps
               split: split_indicator)
  qed (auto intro!: order_continuous_intros sup_continuous_mono lfp_upperbound
            intro: le_funI add_nonneg_nonneg
            simp: bot_ennreal split: split_indicator)
  also have "lfp (?F (HLD {t})) s = emeasure (T s) {xspace (T s). (HLD (-{t}) suntil HLD {t}) x}"
    by (rule emeasure_suntil_disj[symmetric]) (auto simp: HLD_iff)
  finally show ?thesis
    by (simp add: HLD_iff[abs_def] ev_eq_suntil)
qed

lemma AE_suntil:
  assumes [measurable]: "Measurable.pred S P"
  shows "(AE x in T s. (not (HLD {t}) suntil (HLD {t} aand nxt P)) x) 
   (AE x in T s. ev (HLD {t}) x)  (AE x in T t. P x)"
  apply (subst (1 2 3) T.prob_Collect_eq_1[symmetric])
  apply simp
  apply simp
  apply simp
  apply (simp_all add: measure_def emeasure_suntil_HLD del: space_T nxt.simps)
  apply (auto simp: T.emeasure_eq_measure mult_eq_1)
  done

subsection ‹Fairness›

definition fair :: "'s  's  's stream  bool" where
  "fair s t = alw (ev (HLD {s})) impl alw (ev (HLD {s} aand nxt (HLD {t})))"

lemma AE_T_fair:
  assumes "t'  K t"
  shows "AE ω in T s. fair t t' ω"
proof -
  let ?M = "λP s. emeasure (T s) {ωspace (T s). P ω}"
  let ?t = "HLD {t}" and ?t' = "HLD {t'}"
  define N where "N = alw (ev ?t) aand alw (not (?t aand nxt ?t'))"
  let ?until = "not ?t suntil (?t aand nxt (not ?t' aand nxt N))"
  have N_stl: "ω. N ω  N (stl ω)"
    by (auto simp: N_def)
  have [measurable]: "Measurable.pred S N"
    unfolding N_def by measurable

  let ?c = "pmf (K t) t'"
  let ?R = "λx. 1  x * (1 - ennreal ?c)"
  have "mono ?R"
    by (intro monoI mult_right_mono inf_mono) (auto simp: mono_def field_simps )
  have "s. ?M N s  gfp ?R"
  proof (induction rule: gfp_ordinal_induct[OF ‹mono ?R])
    fix x s assume x: "s. ?M N s  x"
    { fix ω assume "N ω"
      then have "ev (HLD {t}) ω" "N ω"
        by (auto simp: N_def)
      then have "?until ω"
        by (induct rule: ev_induct_strong) (auto simp: N_def intro: suntil.intros dest: N_stl) }
    then have "?M N s  ?M ?until s"
      by (intro emeasure_mono_AE) auto
    also have " = ?M (ev ?t) s * ?M (not ?t' aand nxt N) t"
      by (simp_all add: emeasure_suntil_HLD del: nxt.simps space_T)
    also have "  ?M (ev ?t) s * (+s'. 1  x * indicator (UNIV - {t'}) s' K t)"
      by (auto intro!: mult_left_mono nn_integral_mono T.measure_le_1 emeasure_mono
               split: split_indicator simp add: x emeasure_Collect_T[of _ t] simp del: space_T)
    also have "  1 * (+s'. 1  x * indicator (UNIV - {t'}) s' K t)"
      by (intro mult_right_mono T.measure_le_1) simp
    finally show "?M N s  1  x * (1 - ennreal ?c)"
      by (subst (asm) nn_integral_cmult_indicator) (auto simp: emeasure_Diff emeasure_pmf_single)
  qed (auto intro: Inf_greatest)
  also
  from ‹mono ?R have "gfp ?R = ?R (gfp ?R)" by (rule gfp_unfold)
  then have "gfp ?R  ?R (gfp ?R)" by simp
  with assms[THEN pmf_positive] have "gfp ?R  0"
    by (cases "gfp ?R")
       (auto simp: top_unique inf_ennreal.rep_eq field_simps mult_le_0_iff ennreal_1[symmetric]
                   pmf_le_1 ennreal_minus ennreal_mult[symmetric] ennreal_le_iff2 inf_min min_def
             simp del: ennreal_1
             split: if_split_asm)
  finally have "s. AE ω in T s. ¬ N ω"
    by (subst AE_iff_measurable[OF _ refl]) (auto intro: antisym simp: le_fun_def)
  then have "AE ω in T s. alw (not N) ω"
    by (intro AE_T_alw) auto
  moreover
  { fix ω assume "alw (ev (HLD {t})) ω"
    then have "alw (alw (ev (HLD {t}))) ω"
      unfolding alw_alw .
    moreover assume "alw (not N) ω"
    then have "alw (alw (ev (HLD {t})) impl ev (HLD {t} aand nxt (HLD {t'}))) ω"
      unfolding N_def not_alw_iff not_ev_iff de_Morgan_disj de_Morgan_conj not_not imp_conv_disj .
    ultimately have "alw (ev (HLD {t} aand nxt (HLD {t'}))) ω"
      by (rule alw_mp) }
  then have "ω. alw (not N) ω  fair t t' ω"
    by (auto simp: fair_def)
  ultimately show ?thesis
    by (simp add: eventually_mono)
qed

lemma enabled_imp_trancl:
  assumes "alw (HLD B) ω" "enabled s ω"
  shows "alw (HLD (acc_on B `` {s})) ω"
proof -
  define t where "t = s"
  then have "(s, t)  acc_on B"
    by auto
  moreover note ‹alw (HLD B) ω
  moreover note ‹enabled s ω[unfolded t == s[symmetric]]
  ultimately show ?thesis
  proof (coinduction arbitrary: t ω rule: alw_coinduct)
    case stl from this(1,2,3) show ?case
      by (auto simp: enabled.simps[of _ ω] alw.simps[of _ ω] HLD_iff
                 intro!: exI[of _ "shd ω"] rtrancl_trans[of s t])
  next
    case (alw t ω) then show ?case
     by (auto simp: HLD_iff enabled.simps[of _ ω] alw.simps[of _ ω] intro!: rtrancl_trans[of s t])
  qed
qed

lemma AE_T_reachable: "AE ω in T s. alw (HLD (acc `` {s})) ω"
  using AE_T_enabled
proof eventually_elim
  fix ω assume "enabled s ω"
  from enabled_imp_trancl[of UNIV, OF _ this]
  show "alw (HLD (acc `` {s})) ω"
    by (auto simp: HLD_iff[abs_def] all_imp_alw)
qed

lemma AE_T_all_fair: "AE ω in T s. (t,t')SIGMA t:UNIV. K t. fair t t' ω"
proof -
  let ?Rn = "SIGMA s:(acc `` {s}). K s"
  have "AE ω in T s. (t,t')?Rn. fair t t' ω"
  proof (subst AE_ball_countable)
    show "countable ?Rn"
      by (intro countable_SIGMA countable_rtrancl[OF countable_Image]) (auto simp: Image_def)
  qed (auto intro!: AE_T_fair)
  then show ?thesis
    using AE_T_reachable
  proof (eventually_elim, safe)
    fix ω t t' assume "(t,t')?Rn. fair t t' ω" "t'  K t" and alw: "alw (HLD (acc `` {s})) ω"
    moreover
    { assume "t  acc `` {s}"
      then have "alw (not (HLD {t})) ω"
        by (intro alw_mono[OF alw]) (auto simp: HLD_iff)
      then have "not (alw (ev (HLD {t}))) ω"
        unfolding not_alw_iff not_ev_iff by auto
      then have "fair t t' ω"
        unfolding fair_def by auto }
    ultimately show "fair t t' ω"
      by auto
  qed
qed

lemma fair_imp: assumes "fair t t' ω" "alw (ev (HLD {t})) ω" shows "alw (ev (HLD {t'})) ω"
proof -
  { fix ω assume "ev (HLD {t} aand nxt (HLD {t'})) ω" then have "ev (HLD {t'}) ω"
      by induction auto }
  with assms show ?thesis
    by (auto simp: fair_def elim!: alw_mp intro: all_imp_alw)
qed

lemma AE_T_ev_HLD:
  assumes exiting: "t. (s, t)  acc_on (-B)  t'B. (t, t')  acc"
  assumes fin: "finite (acc_on (-B) `` {s})"
  shows "AE ω in T s. ev (HLD B) ω"
  using AE_T_all_fair AE_T_enabled
proof eventually_elim
  fix ω assume fair: "(t, t')(SIGMA s:UNIV. K s). fair t t' ω" and "enabled s ω"

  show "ev (HLD B) ω"
  proof (rule ccontr)
    assume "¬ ev (HLD B) ω"
    then have "alw (HLD (- B)) ω"
      by (simp add: not_ev_iff HLD_iff[abs_def])
    from enabled_imp_trancl[OF this ‹enabled s ω]
    have "alw (HLD (acc_on (-B) `` {s})) ω"
      by (simp add: Diff_eq)
    from pigeonhole_stream[OF this fin]
    obtain t where "(s, t)  acc_on (-B)" "alw (ev (HLD {t})) ω"
      by auto
    from exiting[OF this(1)] obtain t' where "(t, t')  acc" "t'  B"
      by auto
    from this(1) have "alw (ev (HLD {t'})) ω"
    proof induction
      case (step u w) then show ?case
        using fair fair_imp[of u w ω] by auto
    qed fact
    { assume "ev (HLD {t'}) ω" then have "ev (HLD B) ω"
      by (rule ev_mono) (auto simp: HLD_iff t'  B) }
    then show False
      using ‹alw (ev (HLD {t'})) ω ¬ ev (HLD B) ω by auto
  qed
qed

lemma AE_T_ev_HLD':
  assumes exiting: "s. s  X  tX. (s, t)  acc"
  assumes fin: "finite (-X)"
  shows "AE ω in T s. ev (HLD X) ω"
proof (rule AE_T_ev_HLD)
  show "t. (s, t)  acc_on (- X)  t'X. (t, t')  acc"
    using exiting by (auto elim: rtrancl.cases)
  have "acc_on (- X) `` {s}  -X  {s}"
    by (auto elim: rtrancl.cases)
  with fin show "finite (acc_on (- X) `` {s})"
    by (auto dest: finite_subset )
qed

lemma AE_T_max_sfirst:
  assumes [measurable]: "Measurable.pred S X"
  assumes AE: "AE ω in T c. sfirst X (c ## ω) < " and "0 < e"
  shows "N::nat. 𝒫(ω in T c. N < sfirst X (c ## ω)) < e" (is "N. ?P N < e")
proof -
  have "?P  measure (T c) (N::nat. {bT  space (T c). N < sfirst X (c ## bT)})"
    using dual_order.strict_trans enat_ord_simps(2)
    by (intro T.finite_Lim_measure_decseq) (force simp: decseq_Suc_iff simp del: enat_ord_simps)+
  also have "measure (T c) (N::nat. {bT  space (T c). N < sfirst X (c ## bT)}) =
      𝒫(bT in T c. sfirst X (c ## bT) = )"
    by (auto simp del: not_infinity_eq intro!: arg_cong[where f="measure (T c)"])
       (metis less_irrefl not_infinity_eq)
  also have "𝒫(bT in T c. sfirst X (c ## bT) = ) = 0"
    using AE by (intro T.prob_eq_0_AE) auto
  finally have "N. nN. norm (?P n - 0) < e"
    using 0 < e by (rule LIMSEQ_D)
  then show ?thesis
    by (auto simp: measure_nonneg)
qed

subsection ‹First Hitting Time›

lemma nn_integral_sfirst_finite':
  assumes "s  H"
  assumes [simp]: "finite (acc_on (-H) `` {s})"
  assumes until: "AE ω in T s. ev (HLD H) ω"
  shows "(+ ω. sfirst (HLD H) ω T s)  "
proof -
  have R_ne[simp]: "acc_on (-H) `` {s}  {}"
    by auto
  have [measurable]: "H  sets (count_space UNIV)"
    by simp

  let ?Pf = "λn t. 𝒫(ω in T t. enat n < sfirst (HLD H) (t ## ω))"
  have Pf_mono: "N n t. N  n  ?Pf n t  ?Pf N t"
    by (auto intro!: T.finite_measure_mono simp del: enat_ord_code(1) simp: enat_ord_code(1)[symmetric])

  have not_H: "t. (s, t)  acc_on (-H)  t  H"
    using s  H by (auto elim: rtrancl.cases)

  have "F n in sequentially. tacc_on (-H)``{s}. ?Pf n t < 1"
  proof (safe intro!: eventually_ball_finite)
    fix t assume "(s, t)  acc_on (-H)"
    then have "AE ω in T t. sfirst (HLD H) (t ## ω) < "
      unfolding sfirst_finite
    proof induction
      case (step t u) with step.IH show ?case
        by (subst (asm) AE_T_iff) (auto simp: ev_Stream not_H)
    qed (simp add: ev_Stream eventually_frequently_simps until)
    from AE_T_max_sfirst[OF _ this, of 1]
    obtain N where "?Pf N t < 1" by auto
    with Pf_mono[of N] show "F n in sequentially. ?Pf n t < 1"
      by (auto simp: eventually_sequentially intro: le_less_trans)
  qed simp
  then obtain n where "t. (s, t)  acc_on (-H)  ?Pf n t < 1"
    by (auto simp: eventually_sequentially)
  moreover define d where "d = Max (?Pf n ` acc_on (-H) `` {s})"
  ultimately have d: "0  d" "d < 1" "t. (s, t)  acc_on (-H)  ?Pf (Suc n) t  d"
    using Pf_mono[of n "Suc n"] by (auto simp: Max_ge_iff measure_nonneg)

  let ?F = "λF ω. if shd ω  H then 0 else F (stl ω) + 1 :: ennreal"
  have "sup_continuous ?F"
    by (intro order_continuous_intros)
  then have "mono ?F"
    by (rule sup_continuous_mono)
  have lfp_nonneg[simp]: "ω. 0  lfp ?F ω"
    by (subst lfp_unfold[OF ‹mono ?F]) auto

  let ?I = "λF s. +t. (if t  H then 0 else F t + 1) K s"
  have "sup_continuous ?I"
    by (intro order_continuous_intros) auto
  then have "mono ?I"
    by (rule sup_continuous_mono)

  define p where "p = Suc n / (1 - d)"
  have p: "p = Suc n + d * p"
    unfolding p_def using d(1,2) by (auto simp: field_simps)
  have [simp]: "0  p"
    using d(1,2) by (auto simp: p_def)

  have "(+ ω. sfirst (HLD H) ω T s) = (+ ω. lfp ?F ω T s)"
  proof (intro nn_integral_cong_AE)
    show "AE x in T s. sfirst (HLD H) x = lfp ?F x"
      using until
    proof eventually_elim
      fix ω assume "ev (HLD H) ω" then show "sfirst (HLD H) ω = lfp ?F ω"
        by (induction rule: ev_induct_strong;
            subst lfp_unfold[OF ‹mono ?F], simp add: HLD_iff[abs_def] ac_simps max_absorb2)
    qed
  qed
  also have " = lfp (?I^^Suc n) s"
    unfolding lfp_funpow[OF ‹mono ?I]
    by (subst nn_integral_T_lfp)
       (auto simp: nn_integral_add max_absorb2 intro!: order_continuous_intros)
  also have "lfp (?I^^Suc n) t  p" if "(s, t)  acc_on (-H)" for t
    using that
  proof (induction arbitrary: t rule: lfp_ordinal_induct[of "?I^^Suc n"])
    case (step S)
    have "(?I^^i) S t  i + ?Pf i t * ennreal p" for i
      using step(3)
    proof (induction i arbitrary: t)
      case 0 then show ?case
        using T.prob_space step(1)
        by (auto simp add: zero_ennreal_def[symmetric] not_H zero_enat_def[symmetric] one_ennreal_def[symmetric])
    next
      case (Suc i)
      then have "t  H"
        by (auto simp: not_H)
      from Suc.prems have "t'. t'  K t  t'  H  (s, t')  acc_on (-H)"
        by (rule rtrancl_into_rtrancl) (insert Suc.prems, auto dest: not_H)
      then have "(?I ^^ Suc i) S t  ?I (λt. i + ennreal (?Pf i t) * p) t"
        by (auto simp: AE_measure_pmf_iff simp del: sfirst_eSuc space_T
                 intro!: nn_integral_mono_AE add_mono max.mono Suc)
      also have "  (+ t. ennreal (Suc i) + ennreal 𝒫(ω in T t. enat i < sfirst (HLD H) (t ## ω)) * p K t)"
        by (intro nn_integral_mono) auto
      also have "  Suc i + ennreal (?Pf (Suc i) t) * p"
        unfolding T.emeasure_eq_measure[symmetric]
        by (subst (2) emeasure_Collect_T)
           (auto simp: t  H eSuc_enat[symmetric] nn_integral_add nn_integral_multc ennreal_of_nat_eq_real_of_nat)
      finally show ?case
        by (simp add: ennreal_of_nat_eq_real_of_nat)
    qed
    then have "(?I^^Suc n) S t  Suc n + ?Pf (Suc n) t * ennreal p" .
    also have "  p"
      using d step by (subst (2) p) (auto intro!: mult_right_mono simp: ennreal_of_nat_eq_real_of_nat ennreal_mult)
    finally show ?case .
  qed (auto simp: SUP_least intro!: mono_pow ‹mono ?I simp del: funpow.simps)
  finally show ?thesis
    unfolding p_def by (auto simp: top_unique)
qed

lemma nn_integral_sfirst_finite:
  assumes [simp]: "finite (acc_on (-H) `` {s})"
  assumes until: "AE ω in T s. ev (HLD H) ω"
  shows "(+ ω. sfirst (HLD H) (s ## ω) T s)  "
proof cases
  assume "s  H" then show ?thesis
    using nn_integral_sfirst_finite'[of s H] until by (simp add: nn_integral_add)
qed (simp add: sfirst.simps)

lemma prob_T:
  assumes P: "Measurable.pred S P"
  shows "𝒫(ω in T s. P ω) = (t. 𝒫(ω in T t. P (t ## ω)) K s)"
  using emeasure_Collect_T[OF P, of s] unfolding T.emeasure_eq_measure
  by (subst (asm) nn_integral_eq_integral)
     (auto intro!: measure_pmf.integrable_const_bound[where B=1])

lemma T_subprob[measurable]: "T  measurable (measure_pmf I) (subprob_algebra S)"
  by (auto intro!: space_bind simp: space_subprob_algebra) unfold_locales

subsection ‹Markov chain with Initial Distribution›

definition T' :: "'s pmf  's stream measure" where
  "T' I = bind I (λs. distr (T s) S ((##) s))"

lemma distr_Stream_subprob:
  "(λs. distr (T s) S ((##) s))  measurable (measure_pmf I) (subprob_algebra S)"
  apply (intro measurable_distr2[OF _ T_subprob])
  apply (subst measurable_cong_sets[where M'="count_space UNIV M S" and N'=S])
  apply (rule sets_pair_measure_cong)
  apply auto
  done

lemma sets_T': "sets (T' I) = sets S"
  by (simp add: T'_def)

lemma prob_space_T': "prob_space (T' I)"
  unfolding T'_def
proof (rule measure_pmf.prob_space_bind)
  show "AE s in I. prob_space (distr (T s) S ((##) s))"
    by (intro AE_measure_pmf_iff[THEN iffD2] ballI T.prob_space_distr) simp
qed (rule distr_Stream_subprob)

lemma AE_T':
  assumes [measurable]: "Measurable.pred S P"
  shows "(AE x in T' I. P x)  (sI. AE x in T s. P (s ## x))"
  unfolding T'_def by (simp add: AE_bind[OF distr_Stream_subprob] AE_measure_pmf_iff AE_distr_iff)

lemma emeasure_T':
  assumes [measurable]: "X  sets S"
  shows "emeasure (T' I) X = (+s. emeasure (T s) {ωspace S. s ## ω  X} I)"
  unfolding T'_def
  by (simp add: emeasure_bind[OF _ distr_Stream_subprob] emeasure_distr vimage_def Int_def conj_ac)

lemma prob_T':
  assumes [measurable]: "Measurable.pred S P"
  shows "𝒫(x in T' I. P x) = (s. 𝒫(x in T s. P (s ## x)) I)"
proof -
  interpret T': prob_space "T' I" by (rule prob_space_T')
  show ?thesis
    using emeasure_T'[of "{xspace (T' I). P x}" I]
    unfolding T'.emeasure_eq_measure T.emeasure_eq_measure sets_eq_imp_space_eq[OF sets_T']
    apply simp
    apply (subst (asm) nn_integral_eq_integral)
    apply (auto intro!: measure_pmf.integrable_const_bound[where B=1] integral_cong arg_cong2[where f=measure]
                simp: AE_measure_pmf measure_nonneg space_stream_space)
    done
qed

lemma T_eq_T': "T s = T' (K s)"
proof (rule measure_eqI)
  fix X assume X: "X  sets (T s)"
  then have [measurable]: "X  sets S"
    by simp
  have X_eq: "X = {xspace (T s). x  X}"
    using sets.sets_into_space[OF X] by auto
  show "emeasure (T s) X = emeasure (T' (K s)) X"
    apply (subst X_eq)
    apply (subst emeasure_Collect_T, simp)
    apply (subst emeasure_T', simp)
    apply simp
    done
qed (simp add: sets_T')

lemma T_eq_bind: "T s = (measure_pmf (K s)  (λt. distr (T t) S ((##) t)))"
  by (subst T_eq_T') (simp add: T'_def)

lemma T_split:
  "T s = (T s  (λω. distr (T ((s ## ω) !! n)) S (λω'. stake n ω @- ω')))"
proof (induction n arbitrary: s)
  case 0 then show ?case
    apply (simp add: distr_cong[OF refl sets_T[symmetric, of s] refl])
    apply (subst bind_const')
    apply unfold_locales
    ..
next
  case (Suc n)
  let ?K = "measure_pmf (K s)" and ?m = "λn ω ω'. stake n ω @- ω'"
  note sets_stream_space_cong[simp, measurable_cong]

  have "T s = (?K  (λt. distr (T t) S ((##) t)))"
    by (rule T_eq_bind)
  also have " = (?K  (λt. distr (T t  (λω. distr (T ((t ## ω) !! n)) S (?m n ω))) S ((##) t)))"
    unfolding Suc[symmetric] ..
  also have " = (?K  (λt. T t  (λω. distr (distr (T ((t ## ω) !! n)) S (?m n ω)) S ((##) t))))"
    by (simp add: distr_bind[where K=S, OF measurable_distr2[where M=S]] space_stream_space)
  also have " = (?K  (λt. T t  (λω. distr (T ((t ## ω) !! n)) S (?m (Suc n) (t ## ω)))))"
    by (simp add: distr_distr space_stream_space comp_def)
  also have " = (?K  (λt. distr (T t) S ((##) t)  (λω. distr (T (ω !! n)) S (?m (Suc n) ω))))"
    by (simp add: space_stream_space bind_distr[OF _ measurable_distr2[where M=S]] del: stake.simps)
  also have " = (T s  (λω. distr (T (ω !! n)) S (?m (Suc n) ω)))"
    unfolding T_eq_bind[of s]
    by (subst bind_assoc[OF measurable_distr2[where M=S] measurable_distr2[where M=S], OF _ T_subprob])
       (simp_all add: space_stream_space del: stake.simps)
  finally show ?case
    by simp
qed

lemma nn_integral_T_split:
  assumes f[measurable]: "f  borel_measurable S"
  shows "(+ω. f ω T s) = (+ω. (+ω'. f (stake n ω @- ω') T ((s ## ω) !! n)) T s)"
  apply (subst T_split[of s n])
  apply (simp add: nn_integral_bind[OF f measurable_distr2[where M=S]])
  apply (subst nn_integral_distr)
  apply (simp_all add: space_stream_space)
  done

lemma emeasure_T_split:
  assumes P[measurable]: "Measurable.pred S P"
  shows "emeasure (T s) {ωspace (T s). P ω} =
      (+ω. emeasure (T ((s ## ω) !! n)) {ω'space (T ((s ## ω) !! n)). P (stake n ω @- ω')} T s)"
  apply (subst T_split[of s n])
  apply (subst emeasure_bind[OF _ measurable_distr2[where M=S]])
  apply (simp_all add: )
  apply (simp add: space_stream_space)
  apply (subst emeasure_distr)
  apply simp_all
  apply (simp_all add: space_stream_space)
  done

lemma prob_T_split:
  assumes P[measurable]: "Measurable.pred S P"
  shows "𝒫(ω in T s. P ω) = (ω. 𝒫(ω' in T ((s ## ω) !! n). P (stake n ω @- ω')) T s)"
  using emeasure_T_split[OF P, of s n]
  unfolding T.emeasure_eq_measure
  by (subst (asm) nn_integral_eq_integral)
     (auto intro!: T.integrable_const_bound[where B=1] measure_measurable_subprob_algebra2[where N=S]
           simp: T.emeasure_eq_measure SIGMA_Collect_eq)

lemma enabled_imp_alw:
  "(sX. set_pmf (K s))  X  x  X  enabled x ω  alw (HLD X) ω"
proof (coinduction arbitrary: ω x)
  case alw then show ?case
    unfolding enabled.simps[of _ ω]
    by (auto simp: HLD_iff)
qed

lemma alw_HLD_iff_sconst:
  "alw (HLD {x}) ω  ω = sconst x"
proof
  assume "alw (HLD {x}) ω" then show "ω = sconst x"
    by (coinduction arbitrary: ω) (auto simp: HLD_iff)
qed (auto simp: alw_sconst HLD_iff)

lemma enabled_iff_sconst:
  assumes [simp]: "set_pmf (K x) = {x}" shows "enabled x ω  ω = sconst x"
proof
  assume "enabled x ω" then show "ω = sconst x"
    by (coinduction arbitrary: ω) (auto elim: enabled.cases)
next
  assume "ω = sconst x" then show "enabled x ω"
    by (coinduction arbitrary: ω) auto
qed

lemma AE_sconst:
  assumes [simp]: "set_pmf (K x) = {x}"
  shows "(AE ω in T x. P ω)  P (sconst x)"
proof -
  have "(AE ω in T x. P ω)  (AE ω in T x. P ω  ω = sconst x)"
    using AE_T_enabled[of x] by (simp add: enabled_iff_sconst)
  also have " = (AE ω in T x. P (sconst x)  ω = sconst x)"
    by (simp del: AE_conj_iff cong: rev_conj_cong)
  also have " = (AE ω in T x. P (sconst x))"
    using AE_T_enabled[of x] by (simp add: enabled_iff_sconst)
  finally show ?thesis
    by simp
qed

lemma ev_eq_lfp: "ev P = lfp (λF ω. P ω  (¬ P ω  F (stl ω)))"
  unfolding ev_def by (intro antisym lfp_mono) blast+

lemma INF_eq_zero_iff_ennreal: "((iA. f i) = (0::ennreal)) = (x>0. iA. f i < x)"
  using INF_eq_bot_iff[where 'a=ennreal] unfolding bot_ennreal_def zero_ennreal_def by auto

lemma inf_continuous_cmul: 
  fixes c :: ennreal
  assumes f: "inf_continuous f" and c: "c < " 
  shows "inf_continuous (λx. c * f x)"
proof (rule inf_continuous_compose[OF _ f], clarsimp simp add: inf_continuous_def)
  fix M :: "nat  ennreal" assume M: "decseq M" 
  show "c * (i. M i) = (i. c * M i)"
    using M
    by (intro LIMSEQ_unique[OF ennreal_tendsto_cmult[OF c] LIMSEQ_INF] LIMSEQ_INF)
       (auto simp: decseq_def mult_left_mono)
qed

lemma AE_T_ev_HLD_infinite:
  fixes X :: "'s set" and r :: real
  assumes "r < 1"
  assumes r: "x. x  X  measure (K x) X  r"
  shows "AE ω in T x. ev (HLD (- X)) ω"
proof -
  { fix x assume "x  X"
    have "0  r" using r[OF x  X] measure_nonneg[of "K x" X] by (blast  intro: order.trans)
    define P where "P F x = +y. indicator X y * (F y  1) K x" for F x
    have [measurable]: "X  sets (count_space UNIV)" by auto
    have bnd: "(+ y. indicator X y * (f y  1) K x)  1" for x f
      by (intro measure_pmf.nn_integral_le_const AE_pmfI) (auto split: split_indicator)
    have "emeasure (T x) {ωspace (T x). alw (HLD X) ω} =
      emeasure (T x) {ωspace (T x). gfp (λF ω. shd ω  X  F (stl ω)) ω}"
      by (simp add: alw_def HLD_def)
    also have " = gfp P x"
      apply (rule emeasure_gfp)
      apply (auto intro!: order_continuous_intros inf_continuous_cmul split: split_indicator simp: P_def)
      subgoal for x f using bnd[of x f] by (auto simp: top_unique)
      subgoal for P x
        apply (subst T_eq_bind)
        apply (subst emeasure_bind[where N=S])
        apply simp
        apply (rule measurable_distr2[where M=S])
        apply (auto intro: T_subprob[THEN measurable_space] intro!: nn_integral_cong_AE AE_pmfI
            simp: emeasure_distr split: split_indicator)
        apply (simp_all add: space_stream_space T.emeasure_le_1 inf.absorb1)
        done
      apply (intro le_funI)
      apply (subst nn_integral_indicator[symmetric])
      apply simp
      apply (intro nn_integral_mono)
      apply (auto split: split_indicator)
      done
    also have "  (INF n. ennreal r ^ n)"
    proof (intro INF_greatest)
      have mono_P: "mono P"
        by (force simp: le_fun_def mono_def P_def intro!: nn_integral_mono intro: le_infI1 split: split_indicator)
      fix n show "gfp P x  ennreal r ^ n"
        using x  X
      proof (induction n arbitrary: x)
        case 0 then show ?case
          by (subst gfp_unfold[OF mono_P]) (auto intro!: measure_pmf.nn_integral_le_const AE_pmfI split: split_indicator simp: P_def)
      next
        case (Suc n x)
        have "gfp P x = P (gfp P) x" by (subst gfp_unfold[OF mono_P]) rule
        also have "  P (λx. ennreal r ^ n) x"
          unfolding P_def[of _ x] by (auto intro!: nn_integral_mono le_infI1 Suc split: split_indicator)
        also have "  ennreal r ^ (Suc n)"
          using Suc by (auto simp: P_def nn_integral_multc measure_pmf.emeasure_eq_measure intro!: mult_mono ennreal_leI r)
        finally show ?case .
      qed
    qed
    also have " = 0"
      unfolding ennreal_power[OF 0  r]
    proof (intro LIMSEQ_unique[OF LIMSEQ_INF])
      show "decseq (λi. ennreal (r ^ i))"
        using 0  r r < 1 by (auto intro!: ennreal_leI power_decreasing simp: decseq_def)
      have "(λi. ennreal (r ^ i))  ennreal 0"
        using 0  r r < 1 by (intro tendsto_ennrealI LIMSEQ_power_zero) auto
      then show "(λi. ennreal (r ^ i))  0" by simp
    qed
    finally have *: "emeasure (T x) {ωspace (T x). alw (HLD X) ω} = 0" by auto
    have "AE ω in T x. ev (HLD (- X)) ω"
      by (rule AE_I[OF _ *]) (auto simp: not_ev_iff not_HLD[symmetric]) }
  note * = this
  show ?thesis
    apply (clarsimp simp add: AE_T_iff[of _ x])
    subgoal for x'
      by (cases "x'  X") (auto simp add: ev_Stream *)
    done
qed
  
subsection ‹Trace space with Restriction›

definition "rT x = restrict_space (T x) {ω. enabled x ω}"

lemma space_rT: "ω  space (rT x)  enabled x ω"
  by (auto simp: rT_def space_restrict_space space_stream_space)

lemma Collect_enabled_S[measurable]: "Collect (enabled x)  sets S"
proof -
  have "Collect (enabled x) = {ωspace S. enabled x ω}"
    by (auto simp: space_stream_space)
  then show ?thesis
    by simp
qed

lemma space_rT_in_S: "space (rT x)  sets S"
  by (simp add: rT_def space_restrict_space)

lemma sets_rT: "A  sets (rT x)  A  sets S  A  {ω. enabled x ω}"
  by (auto simp: rT_def sets_restrict_space space_stream_space)

lemma prob_space_rT: "prob_space (rT x)"
  unfolding rT_def by (auto intro!: prob_space_restrict_space T.emeasure_eq_1_AE AE_T_enabled)

lemma measurable_force_enabled2[measurable]: "force_enabled x  measurable S (rT x)"
  unfolding rT_def
  by (rule measurable_restrict_space2)
     (auto intro: measurable_force_enabled enabled_force_enabled)

lemma space_rT_not_empty[simp]: "space (rT x)  {}"
  by (simp add: rT_def space_restrict_space Ex_enabled)

lemma T_eq_bind': "T x = do { y  measure_pmf (K x) ; ω  T y ; return S (y ## ω) }"
  apply (subst T_eq_bind)
  apply (subst bind_return_distr[symmetric])
  apply (simp_all add: space_stream_space comp_def)
  done

lemma rT_eq_bind: "rT x = do { y  measure_pmf (K x) ; ω  rT y ; return (rT x) (y ## ω) }"
  unfolding rT_def
  apply (subst T_eq_bind)
  apply (subst restrict_space_bind[where K=S])
  apply (rule measurable_distr2[where M=S])
  apply (auto simp del: measurable_pmf_measure1
              simp add: Ex_enabled return_restrict_space intro!: bind_cong )
  apply (subst restrict_space_bind[symmetric, where K=S])
  apply (auto simp add: Ex_enabled space_restrict_space return_cong[OF sets_T]
              intro!:  measurable_restrict_space1 measurable_compose[OF _ return_measurable]
              arg_cong2[where f=restrict_space])
  apply (subst bind_return_distr[unfolded comp_def])
  apply (simp add: space_restrict_space Ex_enabled)
  apply (simp add: measurable_restrict_space1)
  apply (rule measure_eqI)
  apply simp
  apply (subst (1 2) emeasure_distr)
  apply (auto simp: measurable_restrict_space1)
  apply (subst emeasure_restrict_space)
  apply (auto simp: space_restrict_space intro!: emeasure_eq_AE)
  using AE_T_enabled
  apply eventually_elim
  apply (simp add: space_stream_space)
  apply (rule sets_Int_pred)
  apply auto
  apply (simp add: space_stream_space)
  done

lemma snth_rT: "(λx. x !! n)  measurable (rT x) (count_space (acc `` {x}))"
proof -
  have "ω. enabled x ω  (x, ω !! n)  acc"
  proof (induction n arbitrary: x)
    case (Suc n) from Suc.prems Suc.IH[of "shd ω" "stl ω"] show ?case
      by (auto simp: enabled.simps[of x ω] intro: rtrancl_trans)
  qed (auto elim: enabled.cases)
  moreover
  { fix X :: "'s set"
    have [measurable]: "X  count_space UNIV" by simp
    have *: "(λx. x !! n) -` X  space (rT x) =  {ωspace S. ω !! n  X  enabled x ω}"
      by (auto simp: space_stream_space space_rT)
    have "(λx. x !! n) -` X  space (rT x)  sets S"
      unfolding * by measurable }
  ultimately show ?thesis
    by (auto simp: measurable_def space_rT sets_rT)
qed

subsection ‹Bisimulation›

lemma T_coinduct[consumes 1, case_names prob sets cont]:
  assumes "R x M"
  assumes prob: "x M. R x M  prob_space M"
    and sets: "x M. R x M  sets M = sets S"
    and cont': "x M. R x M  M'. (yK x. R y (M' y))  (y. sets (M' y) = S  prob_space (M' y)) 
      M = (measure_pmf (K x)  (λy. distr (M' y) S ((##) y)))"
  shows "T x = M"
  using R x M
proof (coinduction arbitrary: x M rule: measure_eq_stream_space_coinduct)
  case left then show ?case using T.prob_space_axioms[of x] sets_T[of x] by (auto simp: space_prob_algebra)
next
  case (right M) with prob[of M] sets[of M] show ?case by (auto simp: space_prob_algebra)
next
  case (cont x M) with cont'[OF cont] obtain M' where *:
    "(yK x. R y (M' y))"
    "(y. sets (M' y) = S  prob_space (M' y))"
    "M = (measure_pmf (K x)  (λy. distr (M' y) S ((##) y)))"
    by auto
  show ?case
    apply (rule exI[of _ T])
    apply (rule exI[of _ M'])
    apply (rule exI[of _ "K x"])
    using * T.prob_space_axioms sets_T[of x]
    apply (auto simp: space_prob_algebra intro: T_eq_bind)
    done
qed

lemma T_bisim:
  assumes M: "x. prob_space (M x)" "x. sets (M x) = sets S"
    and M_eq: "x. M x = (measure_pmf (K x)  (λs. distr (M s) S ((##) s)))"
  shows "T = M"
proof
  fix x show "T x = M x"
  proof (coinduction arbitrary: x rule: T_coinduct)
    case (cont x) then show ?case
      apply (intro exI[of _ M])
      apply (subst M_eq[of x])
      apply (simp add: M)
      done
  qed fact+
qed

lemma T_subprob'[measurable]: "T  measurable (count_space UNIV) (subprob_algebra S)"
  by (auto intro!: space_bind simp: space_subprob_algebra) unfold_locales

lemma T_subprob''[simp]: "T a  space (subprob_algebra S)"
  using measurable_space[OF T_subprob', of a] by simp

lemma AE_not_suntil_coinduct [consumes 1, case_names ψ φ]:
  assumes "P s"
  assumes ψ: "s. P s  s  ψ"
  assumes φ: "s t. P s  s  φ  t  K s  P t"
  shows "AE ω in T s. not (HLD φ suntil HLD ψ) (s ## ω)"
proof -
  { fix ω have "¬ (HLD φ suntil HLD ψ) (s ## ω) 
      (n. ¬ ((λR. HLD ψ or (HLD φ aand nxt R)) ^^ n)  (s ## ω))"
      unfolding suntil_def
      by (subst sup_continuous_lfp)
         (auto simp add: sup_continuous_def) }
  moreover
  { fix n from P s have "AE ω in T s. ¬ ((λR. HLD ψ or (HLD φ aand nxt R)) ^^ n)  (s ## ω)"
    proof (induction n arbitrary: s)
      case (Suc n) then show ?case
        apply (subst AE_T_iff)
        apply (rule measurable_compose[OF measurable_Stream, where M1="count_space UNIV"])
        apply measurable
        apply simp
        apply (auto simp: bot_fun_def intro!: AE_impI dest: φ ψ)
        done
    qed simp }
  ultimately show ?thesis
    by (simp add: AE_all_countable)
qed

lemma AE_not_suntil_coinduct_strong [consumes 1, case_names ψ φ]:
  assumes "P s"
  assumes P_ψ: "s. P s  s  ψ"
  assumes P_φ: "s t. P s  s  φ  t  K s  P t 
    (AE ω in T t. not (HLD φ suntil HLD ψ) (t ## ω))"
  shows "AE ω in T s. not (HLD φ suntil HLD ψ) (s ## ω)" (is "?nuntil s")
proof -
  have "P s  ?nuntil s"
    using P s by auto
  then show ?thesis
  proof (coinduction arbitrary: s rule: AE_not_suntil_coinduct)
    case (φ t s) then show ?case
      by (auto simp: AE_T_iff[of _ s] suntil_Stream[of _ _ s] dest: P_φ)
  qed (auto simp: suntil_Stream dest: P_ψ)
qed

end

subsection ‹Reward Structure on Markov Chains›

locale MC_with_rewards = MC_syntax K for K :: "'s  's pmf" +
  fixes ι :: "'s  's  ennreal" and ρ :: "'s  ennreal"
  assumes ι_nonneg: "s t. 0  ι s t" and ρ_nonneg: "s. 0  ρ s"
  assumes measurable_ι[measurable]: "(λ(a, b). ι a b)  borel_measurable (count_space UNIV M count_space UNIV)"
begin

definition reward_until :: "'s set  's  's stream  ennreal" where
  "reward_until X = lfp (λF s ω. if s  X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω)))"

lemma measurable_ρ[measurable]: "ρ  borel_measurable (count_space UNIV)"
  by simp

lemma measurable_reward_until[measurable (raw)]:
  assumes [measurable]: "f  measurable M (count_space UNIV)"
  assumes [measurable]: "g  measurable M S"
  shows "(λx. reward_until X (f x) (g x))  borel_measurable M"
proof -
  let ?F = "λF (s, ω). if s  X then 0 else ρ s + ι s (shd ω) + (F (shd ω, stl ω))"
  { fix s ω
    have "reward_until X s ω = lfp ?F (s, ω)"
      unfolding reward_until_def lfp_pair[symmetric] .. }
  note * = this

  have [measurable]: "lfp ?F  borel_measurable (count_space UNIV M S)"
  proof (rule borel_measurable_lfp)
    fix f :: "('s × 's stream)  ennreal"
    assume [measurable]: "f  borel_measurable (count_space UNIV M S)"
    show "?F f  borel_measurable (count_space UNIV M S)"
      unfolding split_beta'
      apply (intro measurable_If)
      apply measurable []
      apply measurable []
      apply (rule predE)
      apply (rule measurable_compose[OF measurable_fst])
      apply measurable []
      done
  qed (auto intro!: ι_nonneg ρ_nonneg order_continuous_intros)
  show ?thesis
    unfolding * by measurable
qed

lemma continuous_reward_until:
  "sup_continuous (λF s ω. if s  X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω)))"
  by (intro ι_nonneg ρ_nonneg order_continuous_intros) (auto simp: sup_continuous_def image_comp)

lemma
  shows reward_until_unfold: "reward_until X s ω =
        (if s  X then 0 else ρ s + ι s (shd ω) + reward_until X (shd ω) (stl ω))"
      (is ?unfold)
proof -
  let ?F = "λF s ω. if s  X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω))"
  { fix s ω have "reward_until X s ω = ?F (reward_until X) s ω"
      unfolding reward_until_def
      apply (subst lfp_unfold)
      apply (rule continuous_reward_until[THEN sup_continuous_mono, of X])
      apply rule
      done }
  note step = this
  show ?unfold
    by (subst step) (auto intro!: arg_cong2[where f="(+)"])
qed

lemma reward_until_simps[simp]:
  shows "s  X  reward_until X s ω = 0"
    and "s  X  reward_until X s ω = ρ s + ι s (shd ω) + reward_until X (shd ω) (stl ω)"
  unfolding reward_until_unfold[of X s ω] by simp_all

lemma reward_until_SCons[simp]:
  "reward_until X s (t ## ω) = (if s  X then 0 else ρ s + ι s t + reward_until X t ω)"
  by simp

lemma nn_integral_reward_until_finite:
  assumes [simp]: "finite (acc `` {s})" (is "finite (?R `` {s})")
  assumes ρ: "t. (s, t)  acc_on (-H)  ρ t < "
  assumes ι: "t t'. (s, t)  acc_on (-H)  t'  K t  ι t t' < "
  assumes ev: "AE ω in T s. ev (HLD H) ω"
  shows "(+ ω. reward_until H s ω T s)  "
proof cases
  assume "s  H" then show ?thesis
    by simp
next
  assume "s   H"
  let ?L = "acc_on (-H)"
  define M where "M = Max ((λ(s, t). ρ s + ι s t) ` (SIGMA t:?L``{s}. K t))"
  have "?L  ?R"
    by (intro rtrancl_mono) auto
  with s  H have subset: "(SIGMA t:?L``{s}. K t)  (?R``{s} × ?R``{s})"
    by (auto intro: rtrancl_into_rtrancl elim: rtrancl.cases)
  then have [simp, intro!]: "finite ((λ(s, t). ρ s + ι s t) ` (SIGMA t:?L``{s}. K t))"
    by (intro finite_imageI) (auto dest: finite_subset)
  { fix t t' assume "(s, t)  ?L" "t  H" "t'  K t"
    then have "(t, t')  (SIGMA t:?L``{s}. K t)"
      by (auto intro: rtrancl_into_rtrancl)
    then have "ρ t + ι t t'  M"
      unfolding M_def by (intro Max_ge) auto }
  note le_M = this

  have fin_L: "finite (?L `` {s})"
    by (intro finite_subset[OF _ assms(1)] Image_mono ?L  ?R order_refl)

  have "M < "
    unfolding M_def
  proof (subst Max_less_iff, safe)
    show "(SIGMA x:?L `` {s}. set_pmf (K x)) = {}  False"
      using s  H by (auto simp add: Sigma_empty_iff set_pmf_not_empty)
    fix t t' assume "(s, t)  ?L" "t'  K t" then show "ρ t + ι t t' < "
      using ρ[of t] ι[of t t'] by simp
  qed

  from set_pmf_not_empty[of "K s"] obtain t where "t  K s"
    by auto
  with le_M[of s t] have "0  M"
    using set_pmf_not_empty[of "K s"] s  H le_M[of s] ι_nonneg[of s] ρ_nonneg[of s]
    by (intro order_trans[OF _ le_M]) auto

  have "AE ω in T s. reward_until H s ω  M * sfirst (HLD H) (s ## ω)"
    using ev AE_T_enabled
  proof eventually_elim
    fix ω assume "ev (HLD H) ω" "enabled s ω"
    moreover define t where "t = s"
    ultimately have "ev (HLD H) ω" "enabled t ω" "t  ?L``{s}"
      by auto
    then show "reward_until H t ω  M * sfirst (HLD H) (t ## ω)"
    proof (induction arbitrary: t rule: ev_induct_strong)
      case (base ω t) then show ?case
        by (auto simp: HLD_iff sfirst_Stream elim: enabled.cases intro: le_M)
    next
      case (step ω t) from step.IH[of "shd ω"] step.prems step.hyps show ?case
        by (auto simp add: HLD_iff enabled.simps[of t] distrib_left sfirst_Stream
                           reward_until_simps[of t]
                 simp del: reward_until_simps
                 intro!: add_mono le_M intro: rtrancl_into_rtrancl)
    qed
  qed
  then have "(+ω. reward_until H s ω T s)  (+ω. M * sfirst (HLD H) (s ## ω) T s)"
    by (rule nn_integral_mono_AE)
  also have " < "
    using 0  M M <  nn_integral_sfirst_finite[OF fin_L ev]
    by (simp add: nn_integral_cmult  less_top[symmetric] ennreal_mult_eq_top_iff)
  finally show ?thesis
    by simp
qed

end

subsection ‹Bisimulation on a relation›

definition rel_set_strong :: "('a  'b  bool)  'a set  'b set  bool"
  where "rel_set_strong R A B  (x y. R x y  (x  A  y  B))"

lemma T_eq_rel_half[consumes 4, case_names prob sets cont]:
  fixes R :: "'s  't  bool" and f :: "'s  't" and S :: "'s set"
  assumes R_def: "s t. R s t  (s  S  f s = t)"
  assumes A[measurable]: "A  sets (stream_space (count_space UNIV))"
    and B[measurable]: "B  sets (stream_space (count_space UNIV))"
    and AB: "rel_set_strong (stream_all2 R) A B" and KL: "rel_fun R (rel_pmf R) K L" and xy: "R x y"
  shows "MC_syntax.T K x A = MC_syntax.T L y B"
proof -
  interpret K: MC_syntax K by unfold_locales
  interpret L: MC_syntax L by unfold_locales

  have "x  S" using R x y by (auto simp: R_def)

  define g where "g t = (SOME s. R s t)" for t
  have measurable_g: "g  count_space UNIV M count_space UNIV" by auto
  have g: "R i j  R (g j) j" for i j
    unfolding g_def by (rule someI)
  
  have K_subset: "x  S  K x  S" for x
    using KL[THEN rel_funD, of x "f x", THEN rel_pmf_imp_rel_set] by (auto simp: rel_set_def R_def)

  have in_S: "AE ω in K.T x. ω  streams S"
    using K.AE_T_enabled
  proof eventually_elim 
    case (elim ω) with x  S show ?case
      apply (coinduction arbitrary: x ω)
      subgoal for x ω using K_subset by (cases ω) (auto simp: K.enabled_Stream)
      done
  qed

  have L_eq: "L y = map_pmf f (K x)" if xy: "R x y" for x y
  proof -
    have "rel_pmf (λx y. x = y) (map_pmf f (K x)) (L y)"
      using KL[THEN rel_funD, OF xy] by (auto intro: pmf.rel_mono_strong simp: R_def pmf.rel_map)
    then show ?thesis unfolding pmf.rel_eq by simp
  qed

  let ?D = "λx. distr (K.T x) K.S (smap f)"
  have prob_space_D: "?D x  space (prob_algebra K.S)" for x 
    by (auto simp: space_prob_algebra K.T.prob_space_distr)

  have D_eq_D: "?D x = ?D x'" if "R x y" "R x' y" for x x' y
  proof (rule stream_space_eq_sstart)
    define A where "A = K.acc `` {x, x'}"
    have x_A: "x  A" "x'  A" by (auto simp: A_def)
    let  = "f ` A"
    show "countable "
      unfolding A_def by (intro countable_image K.countable_acc) auto
    show "prob_space (?D x)" "prob_space (?D x')" by (auto intro!: K.T.prob_space_distr)
    show "sets (?D x) = sets L.S" "sets (?D x') = sets L.S" by auto
    have AE_streams: "AE x in ?D x''. x  streams " if "x''  A" for x''
      apply (simp add: space_stream_space streams_sets AE_distr_iff)
      using K.AE_T_reachable[of x''] unfolding alw_HLD_iff_streams
    proof eventually_elim
      fix s assume "s  streams (K.acc `` {x''})"
      moreover have "K.acc `` {x''}  A"
        using x''  A by (auto simp: A_def Image_def intro: rtrancl_trans)
      ultimately show "smap f s  streams (f ` A)"
        by (auto intro: smap_streams)
    qed
    with x_A show "AE x in ?D x'. x  streams " "AE x in ?D x. x  streams "
      by auto
    from x  A x'  A that show "?D x (sstart (f ` A) xs) = ?D x' (sstart (f ` A) xs)" for xs
    proof (induction xs arbitrary: x x' y)
      case Nil
      moreover have "?D x (streams (f ` A)) = 1" if "x  A" for x
        using AE_streams[of x] that
        by (intro prob_space.emeasure_eq_1_AE[OF K.T.prob_space_distr]) (auto simp: streams_sets)
      ultimately show ?case by simp
    next
      case (Cons z zs x x' y)
      have "rel_pmf (R OO R¯¯) (K x) (K x')"
        using KL[THEN rel_funD, OF Cons(4)] KL[THEN rel_funD, OF Cons(5)]
        unfolding pmf.rel_compp pmf.rel_flip by auto
      then obtain p :: "('s × 's) pmf" where p: "a b. (a, b)  p  (R OO R¯¯) a b" and
        eq: "map_pmf fst p = K x" "map_pmf snd p = K x'"
        by (auto simp: pmf.in_rel)
      let ?S = "stream_space (count_space UNIV)"
      have *: "(##) y -` smap f -` sstart (f ` A) (z # zs) = (if f y = z then smap f -` sstart (f ` A) zs else {})" for y z zs
        by auto
      have **: "?D x (sstart (f ` A) (z # zs)) = (+ y'. (if f y' = z then ?D y' (sstart (f ` A) zs) else 0) K x)" for x
        apply (simp add: emeasure_distr)
        apply (subst K.T_eq_bind)
        apply (subst emeasure_bind[where N="?S"])
           apply simp
          apply (rule measurable_distr2[where M="?S"])
           apply measurable
        apply (intro nn_integral_cong_AE AE_pmfI)
        apply (auto simp add: emeasure_distr)
        apply (simp_all add: * space_stream_space)
        done
      have fst_A: "fst ab  A" if "ab  p" for ab
      proof -
        have "fst ab  K x" using ab  p set_map_pmf [of fst p] by (auto simp: eq)
        with x  A show "fst ab  A"
          by (auto simp: A_def intro: rtrancl.rtrancl_into_rtrancl)
      qed
      have snd_A: "snd ab  A" if "ab  p" for ab
      proof -
        have "snd ab  K x'" using ab  p set_map_pmf [of snd p] by (auto simp: eq)
        with x'  A show "snd ab  A"
          by (auto simp: A_def intro: rtrancl.rtrancl_into_rtrancl)
      qed
      show ?case
        unfolding ** eq[symmetric] nn_integral_map_pmf
        apply (intro nn_integral_cong_AE AE_pmfI)
        subgoal for ab using p[of "fst ab" "snd ab"] by (auto simp: R_def intro!: Cons(1) fst_A snd_A)
        done
    qed
  qed

  have L_eq_D: "L.T y = ?D x"
    using R x y
  proof (coinduction arbitrary: x y rule: L.T_coinduct)
    case (cont x y)
    then have Kx_Ly: "rel_pmf R (K x) (L y)"
      by (rule KL[THEN rel_funD])
    then have *: "y'  L y  x'K x. R x' y'" for y'
      by (auto dest!: rel_pmf_imp_rel_set simp: rel_set_def)
    have **: "y'  L y  R (g y') y'" for y'
      using *[of y'] unfolding g_def by (auto intro: someI)

    have D_SCons_eq_D_D: "distr (K.T i) K.S (λx. z ## smap f x) = distr (?D i) K.S (λx. z ## x)" for i z
      by (subst distr_distr) (auto simp: comp_def)
    have D_eq_D_gi: "?D i = ?D (g (f i))" if i: "i  K x" for i
    proof -
      obtain j where "j  L y" "R i j" "f i = j"
        using Kx_Ly i by (force dest!: rel_pmf_imp_rel_set simp: rel_set_def R_def)
      then show ?thesis
        by (auto intro!: D_eq_D[OF R i j] g)
    qed

    have ***: "?D x = measure_pmf (L y)  (λy. distr (?D (g y)) K.S ((##) y))"
      apply (subst K.T_eq_bind)
      apply (subst distr_bind[of _ _ K.S])
         apply (rule measurable_distr2[of _  _ "K.S"])
          apply (simp_all add: Pi_iff)
      apply (simp add: distr_distr comp_def L_eq[OF cont] map_pmf_rep_eq)
      apply (subst bind_distr[where K=K.S])
         apply measurable []
        apply (rule measurable_distr2[of _  _ "K.S"])
        apply measurable []
        apply (rule measurable_compose[OF measurable_g])
        apply measurable []
       apply simp
      apply (rule bind_measure_pmf_cong[where N="K.S"])
        apply (auto simp: space_subprob_algebra space_stream_space intro!: K.T.subprob_space_distr)
        unfolding D_SCons_eq_D_D D_eq_D_gi ..
    show ?case
      by (intro exI[of _ "λt. distr (K.T (g t)) (stream_space (count_space UNIV)) (smap f)"])
         (auto simp add: K.T.prob_space_distr *** dest: **)
  qed (auto intro: K.T.prob_space_distr)

  have "stream_all2 R s t  (s  streams S  smap f s = t)" for s t 
  proof safe
    show "stream_all2 R s t  s  streams S"
      apply (coinduction arbitrary: s t)
      subgoal for s t by (cases s; cases t) (auto simp: R_def)
      done
    show "stream_all2 R s t  smap f s = t"
      apply (coinduction arbitrary: s t)
      subgoal for s t by (cases s; cases t) (auto simp: R_def)
      done
  qed (auto intro!: stream.rel_refl_strong simp: stream.rel_map R_def streams_iff_sset)
  then have "ω  streams S  ω  A  smap f ω  B" for ω
    using AB by (auto simp: rel_set_strong_def)
  with in_S have "K.T x A = K.T x (smap f -` B  space (K.T x))"
    by (auto intro!: emeasure_eq_AE streams_sets)
  also have " = (distr (K.T x) K.S (smap f)) B"
    by (intro emeasure_distr[symmetric]) auto
  also have " = (L.T y) B" unfolding L_eq_D ..
  finally show ?thesis .
qed

subsection ‹Product Construction›

locale MC_pair =
  K1: MC_syntax K1 + K2: MC_syntax K2 for K1 K2
begin

definition "Kp  λ(a, b). pair_pmf (K1 a) (K2 b)"

sublocale MC_syntax Kp .

definition
  "szipE a b  λ(ω1, ω2). szip (K1.force_enabled a ω1) (K2.force_enabled b ω2)"

lemma szip_rT[measurable]: "(λ(ω1, ω2). szip ω1 ω2)  measurable (K1.rT x1 M K2.rT x2) S"
proof (rule measurable_stream_space2)
  fix n
  have "(λx. (case x of (ω1, ω2)  szip ω1 ω2) !! n) = (λω. (fst ω !! n, snd ω !! n))"
    by auto
  also have "  measurable (K1.rT x1 M K2.rT x2) (count_space UNIV)"
    apply (rule measurable_compose_countable'[OF _ measurable_compose[OF measurable_fst K1.snth_rT, of n]])
    apply (rule measurable_compose_countable'[OF _ measurable_compose[OF measurable_snd K2.snth_rT, of n]])
    apply (auto intro!: K1.countable_acc K2.countable_acc)
    done
  finally show "(λx. (case x of (ω1, ω2)  szip ω1 ω2) !! n)  measurable (K1.rT x1 M K2.rT x2) (count_space UNIV)"
    .
qed

lemma measurable_szipE[measurable]: "szipE a b  measurable (K1.S M K2.S) S"
  unfolding szipE_def by measurable

lemma T_eq_prod: "T = (λ(x1, x2). do { ω1  K1.T x1 ; ω2  K2.T x2 ; return S (szipE x1 x2 (ω1, ω2)) })"
  (is "_ = ?B")
proof (rule T_bisim)
  have T1x: "x. subprob_space (K1.T x)"
    by (rule prob_space_imp_subprob_space) unfold_locales

  interpret T12: pair_prob_space "K1.T x" "K2.T y" for x y
    by unfold_locales
  interpret T1K2: pair_prob_space "K1.T x" "K2 y" for x y
    by unfold_locales

  let ?P = "λx1 x2. K1.T x1 M K2.T x2"

  fix x show "prob_space (?B x)"
    by (auto simp: space_stream_space split: prod.splits
                intro!: prob_space.prob_space_bind prob_space_return
                        measurable_bind[where N=S] measurable_compose[OF _ return_measurable] AE_I2)
       unfold_locales

  show "sets (?B x) = sets S"
    by (simp split: prod.splits add: measurable_bind[where N=S] sets_bind[where N=S] space_stream_space)

  obtain a b where x_eq: "x = (a, b)"
    by (cases x) auto
  show "?B x = (measure_pmf (Kp x)  (λs. distr (?B s) S ((##) s)))"
    unfolding x_eq
    apply (subst K1.T_eq_bind')
    apply (subst K2.T_eq_bind')
    apply (auto
         simp add: space_stream_space bind_assoc[where R=S and N=S] bind_return_distr[symmetric]
                   Kp_def T1K2.bind_rotate[where N=S] split_beta' set_pair_pmf space_subprob_algebra
                   bind_pair_pmf[of "case_prod M" for M, unfolded split, symmetric, where N=S] szipE_def
                   stream_eq_Stream_iff bind_return[where N=S] space_bind[where N=S]
         simp del: measurable_pmf_measure1
         intro!: bind_measure_pmf_cong[where N=S] subprob_space_bind[where N=S] subprob_space_measure_pmf
                 T1x bind_cong[where M="MC_syntax.T K x" for K x] arg_cong2[where f=return])
    done
qed

lemma nn_integral_pT:
  fixes f assumes [measurable]: "f  borel_measurable S"
  shows "(+ω. f ω T (x, y)) = (+ω1. +ω2. f (szipE x y (ω1, ω2)) K2.T y K1.T x)"
  by (simp add: nn_integral_bind[where B=S] nn_integral_return in_S T_eq_prod)

lemma prod_eq_prob_T:
  assumes [measurable]: "Measurable.pred K1.S P1" "Measurable.pred K2.S P2"
  shows "𝒫(ω in K1.T x1. P1 ω) * 𝒫(ω in K2.T x2. P2 ω) =
    𝒫(ω in T (x1, x2). P1 (smap fst ω)  P2 (smap snd ω))"
proof -
  have "𝒫(ω in T (x1, x2). P1 (smap fst ω)  P2 (smap snd ω)) =
    ( x.  xa. indicator {ω  space S. P1 (smap fst ω)  P2 (smap snd ω)} (szipE x1 x2 (x, xa)) MC_syntax.T K2 x2 MC_syntax.T K1 x1)"
    by (subst T_eq_prod)
       (simp add: K1.T.measure_bind[where N=S] K2.T.measure_bind[where N=S] measure_return)
  also have "... = (ω1. ω2. indicator {ωspace K1.S. P1 ω} ω1 * indicator {ωspace K2.S. P2 ω} ω2 K2.T x2 K1.T x1)"
    apply (intro integral_cong_AE)
    apply measurable
    using K1.AE_T_enabled
    apply eventually_elim
    apply (intro integral_cong_AE)
    apply measurable
    using K2.AE_T_enabled
    apply eventually_elim
    apply (auto simp: space_stream_space szipE_def K1.force_enabled K2.force_enabled
                      smap_szip_snd[where g="λx. x"] smap_szip_fst[where f="λx. x"]
                split: split_indicator)
    done
  also have " = 𝒫(ω in K1.T x1. P1 ω) * 𝒫(ω in K2.T x2. P2 ω)"
    by simp
  finally show ?thesis ..
qed

end

end

Theory Trace_Space_Equals_Markov_Processes

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

subsection ‹Trace Space equal to Markov Chains›

theory Trace_Space_Equals_Markov_Processes
  imports Discrete_Time_Markov_Chain
begin

text ‹
  We can construct for each time-homogeneous discrete-time Markov chain a corresponding
  probability space using @{theory Markov_Models.Discrete_Time_Markov_Chain}. The constructed probability space
  has the same probabilities.
›

locale Time_Homogeneous_Discrete_Markov_Process = M?: prob_space +
  fixes S :: "'s set" and X :: "nat  'a  's"
  assumes X [measurable]: "t. X t  measurable M (count_space UNIV)"
  assumes S: "countable S" "n. AE x in M. X n x  S"
  assumes MC: "n s s'.
    𝒫(ω in M. tn. X t ω = s t )  0 
    𝒫(ω in M. X (Suc n) ω = s' ¦ tn. X t ω = s t ) =
    𝒫(ω in M. X (Suc n) ω = s' ¦ X n ω = s n )"
  assumes TH: "n m s t.
    𝒫(ω in M. X n ω = t)  0  𝒫(ω in M. X m ω = t)  0 
    𝒫(ω in M. X (Suc n) ω = s ¦ X n ω = t) = 𝒫(ω in M. X (Suc m) ω = s ¦ X m ω = t)"
begin

context
begin

interpretation pmf_as_measure .

lift_definition I :: "'s pmf" is "distr M (count_space UNIV) (X 0)"
proof -
  let ?X = "distr M (count_space UNIV) (X 0)"
  interpret X: prob_space ?X
    by (auto simp: prob_space_distr)
  have "AE x in ?X. measure ?X {x}  0"
    using S by (subst X.AE_support_countable) (auto simp: AE_distr_iff intro!: exI[of _ S])
  then show "prob_space ?X  sets ?X = UNIV  (AE x in ?X. measure ?X {x}  0)"
    by (simp add: prob_space_distr AE_support_countable)
qed

lemma I_in_S:
  assumes "pmf I s  0" shows "s  S"
proof -
  from ‹pmf I s  0 have "0  𝒫(x in M. X 0 x = s)"
    by transfer (auto simp: measure_distr vimage_def Int_def conj_commute)
  also have "𝒫(x in M. X 0 x = s) = 𝒫(x in M. X 0 x = s  s  S)"
    using S(2)[of 0] by (intro M.finite_measure_eq_AE) auto
  finally show ?thesis
    by (cases "s  S") auto
qed

lift_definition K :: "'s  's pmf" is
  "λs. with (λn. 𝒫(ω in M. X n ω = s)  0)
     (λn. distr (uniform_measure M {ωspace M. X n ω = s}) (count_space UNIV) (X (Suc n)))
     (uniform_measure (count_space UNIV) {s})"
proof (rule withI)
  fix s n assume *: "𝒫(ω in M. X n ω = s)  0"
  let ?D = "distr (uniform_measure M {ωspace M. X n ω = s}) (count_space UNIV) (X (Suc n))"
  have D: "prob_space ?D"
    by (intro prob_space.prob_space_distr prob_space_uniform_measure)
       (auto simp: M.emeasure_eq_measure *)
  then interpret D: prob_space ?D .
  have sets_D: "sets ?D = UNIV"
    by simp
  moreover have "AE x in ?D. measure ?D {x}  0"
    unfolding D.AE_support_countable[OF sets_D]
  proof (intro exI[of _ S] conjI)
    show "countable S" by (rule S)
    show "AE x in ?D. x  S"
      using * S(2)[of "Suc n"] by (auto simp add: AE_distr_iff AE_uniform_measure M.emeasure_eq_measure)
  qed
  ultimately show "prob_space ?D  sets ?D = UNIV  (AE x in ?D. measure ?D {x}  0)"
    using D by blast
qed (auto intro!: prob_space_uniform_measure AE_uniform_measureI)

lemma pmf_K:
  assumes n: "0 < 𝒫(ω in M. X n ω = s)"
  shows "pmf (K s) t = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
proof (transfer fixing: n s t)
  let ?P = "λn. 𝒫(ω in M. X n ω = s)  0"
  let ?D = "λn. distr (uniform_measure M {ωspace M. X n ω = s}) (count_space UNIV) (X (Suc n))"
  let ?U = "uniform_measure (count_space UNIV) {s}"
  show "measure (with ?P ?D ?U) {t} = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
  proof (rule withI)
    fix n' assume "?P n'"
    moreover have "X (Suc n') -` {t}  space M = {xspace M. X (Suc n') x = t}"
      by auto
    ultimately show "measure (?D n') {t} = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
      using n M.measure_uniform_measure_eq_cond_prob[of "λx. X (Suc n') x = t" "λx. X n' x = s"]
      by (auto simp: measure_distr M.emeasure_eq_measure simp del: measure_uniform_measure intro!: TH)
  qed (insert n, simp)
qed

lemma pmf_K2:
  "(n. 𝒫(ω in M. X n ω = s) = 0)  pmf (K s) t = indicator {t} s"
  apply (transfer fixing: s t)
  apply (rule withI)
  apply (auto split: split_indicator)
  done

end

sublocale K: MC_syntax K .

lemma bind_I_K_eq_M: "K.T' I = distr M K.S (λω. to_stream (λn. X n ω))" (is "_ = ?D")
proof (rule stream_space_eq_sstart)
  note streams_sets[measurable]
  note measurable_abs_UNIV[measurable (raw)]
  note sstart_sets[measurable]

  { fix s assume "s  S"
    from K.AE_T_enabled[of s] have "AE ω in K.T s. ω  streams S"
    proof eventually_elim
      fix ω assume "K.enabled s ω" from this sS show "ω  streams S"
      proof (coinduction arbitrary: s ω)
        case streams
        then have 1: "pmf (K s) (shd ω)  0"
          by (simp add: K.enabled.simps[of s] set_pmf_iff)
        have "shd ω  S"
        proof cases
          assume "n. 0 < 𝒫(ω in M. X n ω = s)"
          then obtain n where "0 < 𝒫(ω in M. X n ω = s)" by auto
          with 1 have 2: "𝒫(ω' in M. X (Suc n) ω' = shd ω  X n ω' = s)  0"
            by (simp add: pmf_K cond_prob_def)
          show "shd ω  S"
          proof (rule ccontr)
            assume "shd ω  S"
            with S(2)[of "Suc n"] have "𝒫(ω' in M. X (Suc n) ω' = shd ω  X n ω' = s) = 0"
              by (intro M.prob_eq_0_AE) auto
            with 2 show False by contradiction
          qed
        next
          assume "¬ (n. 0 < 𝒫(ω in M. X n ω = s))"
          then have "pmf (K s) (shd ω) = indicator {shd ω} s"
            by (intro pmf_K2) (auto simp: not_less measure_le_0_iff)
          with 1 sS show ?thesis
            by (auto split: split_indicator_asm)
        qed
        with streams show ?case
          by (cases ω) (auto simp: K.enabled.simps[of s])
      qed
    qed }
  note AE_streams = this

  show "prob_space (K.T' I)"
    by (rule K.prob_space_T')
  show "prob_space ?D"
    by (rule M.prob_space_distr) simp

  show "AE x in K.T' I. x  streams S"
    by (auto simp add: K.AE_T' set_pmf_iff I_in_S AE_distr_iff streams_Stream intro!: AE_streams)
  show "AE x in ?D. x  streams S"
    by (simp add: AE_distr_iff to_stream_in_streams AE_all_countable S)
  show "sets (K.T' I) = sets (stream_space (count_space UNIV))"
    by (simp add: K.sets_T')
  show "sets ?D = sets (stream_space (count_space UNIV))"
    by simp

  fix xs' assume "xs'  []" "xs'  lists S"
  then obtain s xs where xs': "xs' = s # xs" and s: "s  S" and xs: "xs  lists S"
    by (auto simp: neq_Nil_conv del: in_listsD)

  have "emeasure (K.T' I) (sstart S xs') = (+s. emeasure (K.T s) {ωspace K.S. s ## ω  sstart S xs'} I)"
    by (rule K.emeasure_T') measurable
  also have " = (+s'. emeasure (K.T s) (sstart S xs) * indicator {s} s' I)"
    by (intro arg_cong2[where f=emeasure] nn_integral_cong)
       (auto split: split_indicator simp: emeasure_distr vimage_def space_stream_space neq_Nil_conv xs')
  also have " = pmf I s * emeasure (K.T s) (sstart S xs)"
    by (auto simp add: max_def emeasure_pmf_single intro: mult_ac)
  also have "emeasure (K.T s) (sstart S xs) = ennreal (i<length xs. pmf (K ((s#xs)!i)) (xs!i))"
    using xs s
  proof (induction arbitrary: s)
    case Nil then show ?case
      by (simp add: K.T.emeasure_eq_1_AE AE_streams)
  next
    case (Cons t xs)
    have "emeasure (K.T s) (sstart S (t # xs)) =
      emeasure (K.T s) {xspace (K.T s). shd x = t  stl x  sstart S xs}"
      by (intro arg_cong2[where f=emeasure]) (auto simp: space_stream_space)
    also have " = (+t'. emeasure (K.T t') {xspace K.S. t' = t  x  sstart S xs} K s)"
      by (subst K.emeasure_Collect_T) auto
    also have " = (+t'. emeasure (K.T t) (sstart S xs) * indicator {t} t' K s)"
      by (intro nn_integral_cong) (auto split: split_indicator simp: space_stream_space)
    also have " = emeasure (K.T t) (sstart S xs) * pmf (K s) t"
      by (simp add: emeasure_pmf_single max_def)
    finally show ?case
      by (simp add: lessThan_Suc_eq_insert_0 zero_notin_Suc_image prod.reindex Cons
        prod_nonneg ennreal_mult[symmetric])
  qed
  also have "pmf I s * ennreal (i<length xs. pmf (K ((s#xs)!i)) (xs!i)) =
    𝒫(x in M. ilength xs. X i x = (s # xs) ! i)"
    using xs s
  proof (induction xs rule: rev_induct)
    case Nil
    have "pmf I s = prob {x  space M. X 0 x = s}"
      by transfer (simp add: vimage_def Int_def measure_distr conj_commute)
    then show ?case
      by simp
  next
    case (snoc t xs)
    let ?l = "length xs" and ?lt = "length (xs @ [t])" and ?xs' = "s # xs @ [t]"
    have "ennreal (pmf I s) * (i<?lt. pmf (K ((?xs') ! i)) ((xs @ [t]) ! i)) =
      (ennreal (pmf I s) * (i<?l. pmf (K ((s # xs) ! i)) (xs ! i))) * pmf (K ((s # xs) ! ?l)) t"
      by (simp add: lessThan_Suc mult_ac nth_append append_Cons[symmetric] prod_nonneg ennreal_mult[symmetric]
               del: append_Cons)
    also have " = 𝒫(x in M. i?l. X i x = (s # xs) ! i) * pmf (K ((s # xs) ! ?l)) t"
      using snoc by (simp add: ennreal_mult[symmetric])
    also have " = 𝒫(x in M. i?lt. X i x = (?xs') ! i)"
    proof cases
      assume "𝒫(ω in M. i?l. X i ω = (s # xs) ! i) = 0"
      moreover have "𝒫(x in M. i?lt. X i x = (?xs') ! i)  𝒫(ω in M. i?l. X i ω = (s # xs) ! i)"
        by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
      moreover have "𝒫(x in M. i?l. X i x = (s # xs) ! i)  𝒫(ω in M. i?l. X i ω = (s # xs) ! i)"
        by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
      ultimately show ?thesis
        by (simp add: measure_le_0_iff)
    next
      assume "𝒫(ω in M. i?l. X i ω = (s # xs) ! i)  0"
      then have *: "0 < 𝒫(ω in M. i?l. X i ω = (s # xs) ! i)"
        unfolding less_le by simp
      moreover have "𝒫(ω in M. i?l. X i ω = (s # xs) ! i)  𝒫(ω in M. X ?l ω = (s # xs) ! ?l)"
        by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
      ultimately have "𝒫(ω in M. X ?l ω = (s # xs) ! ?l)  0"
        by auto
      then have "pmf (K ((s # xs) ! ?l)) t = 𝒫(ω in M. X ?lt ω = ?xs' ! ?lt ¦ X ?l ω = (s # xs) ! ?l)"
        by (subst pmf_K) (auto simp: less_le)
      also have " = 𝒫(ω in M. X ?lt ω = ?xs' ! ?lt ¦ i?l. X i ω = (s # xs) ! i)"
        using * MC[of ?l "λi. (s # xs) ! i" "?xs' ! ?lt"] by simp
      also have " = 𝒫(ω in M. i?lt. X i ω = ?xs' ! i) / 𝒫(ω in M. i?l. X i ω = (s # xs) ! i)"
        unfolding cond_prob_def
        by (intro arg_cong2[where f="(/)"] arg_cong2[where f=measure]) (auto simp: nth_Cons nth_append split: nat.splits)
      finally show ?thesis
        using * by simp
    qed
    finally show ?case .
  qed
  also have " = emeasure ?D (sstart S xs')"
  proof -
    have "AE x in M. i. X i x  S"
      using S(2) by (simp add: AE_all_countable)
    then have "AE x in M. (ilength xs. X i x = (s # xs) ! i) = (to_stream (λn. X n x)  sstart S xs')"
    proof eventually_elim
      fix x assume "i. X i x  S"
      then have "to_stream (λn. X n x)  streams S"
        by (auto simp: streams_iff_snth to_stream_def)
      then show "(ilength xs. X i x = (s # xs) ! i) = (to_stream (λn. X n x)  sstart S xs')"
        by (simp add: sstart_eq xs' to_stream_def less_Suc_eq_le del: sstart.simps(1) in_sstart)
    qed
    then show ?thesis
      by (auto simp: emeasure_distr M.emeasure_eq_measure intro!: M.finite_measure_eq_AE)
  qed
  finally show "emeasure (K.T' I) (sstart S xs') = emeasure ?D (sstart S xs')" .
qed (rule S)

end

lemma (in MC_syntax) is_THDTMC:
  fixes I :: "'s pmf"
  defines "U  (SIGMA s:UNIV. K s)* `` I"
  shows "Time_Homogeneous_Discrete_Markov_Process (T' I) U (λn ω. ω !! n)"
proof -
  have [measurable]: "U  sets (count_space UNIV)"
    by auto

  interpret prob_space "T' I"
    by (rule prob_space_T')

  { fix s t I
    have "t s. 𝒫(ω in T s. s = t) = indicator {t} s"
      using T.prob_space by (auto split: split_indicator)
    moreover then have "t t' s. 𝒫(ω in T s. shd ω = t'  s = t) = pmf (K t) t' * indicator {t} s"
      by (subst prob_T) (auto split: split_indicator simp: pmf.rep_eq)
    ultimately have "𝒫(ω in T' I. shd (stl ω) = t  shd ω = s) = 𝒫(ω in T' I. shd ω = s) * pmf (K s) t"
      by (simp add: prob_T' pmf.rep_eq) }
  note start_eq = this

  { fix n s t assume "𝒫(ω in T' I. ω !! n = s)  0"
    moreover have "𝒫(ω in T' I. ω !! (Suc n) = t  ω !! n = s) = 𝒫(ω in T' I. ω !! n = s) * pmf (K s) t"
    proof (induction n arbitrary: I)
      case (Suc n) then show ?case
        by (subst (1 2) prob_T') (simp_all del: space_T add: T_eq_T')
    qed (simp add: start_eq)
    ultimately have "𝒫(ω in T' I. stl ω !! n = t ¦ ω !! n = s) = pmf (K s) t"
      by (simp add: cond_prob_def field_simps) }
  note TH = this

  { fix n ω' t assume "𝒫(ω in T' I. in. ω !! i = ω' i)  0"
    moreover have "𝒫(ω in T' I. ω !! (Suc n) = t  (in. ω !! i = ω' i)) =
      𝒫(ω in T' I. in. ω !! i = ω' i) * pmf (K (ω' n)) t"
    proof (induction n arbitrary: I ω')
      case (Suc n)
      have *[simp]: "s P. measure (T' (K s)) {x. s = ω' 0  P x} =
        measure (T' (K (ω' 0))) {x. P x} * indicator {ω' 0} s"
        by (auto split: split_indicator)
      from Suc[of _ "λi. ω' (Suc i)"] show ?case
        by (subst (1 2) prob_T')
           (simp_all add: T_eq_T' all_Suc_split[where P="λi. i  Suc n  Q i" for n Q] conj_commute conj_left_commute sets_eq_imp_space_eq[OF sets_T'])
    qed (simp add: start_eq)
    ultimately have "𝒫(ω in T' I. stl ω !! n = t ¦ in. ω !! i = ω' i) = pmf (K (ω' n)) t"
      by (simp add: cond_prob_def field_simps) }
  note MC = this

  { fix n ω' assume "𝒫(ω in T' I. tn. ω !! t = ω' t)  0"
    moreover have "𝒫(ω in T' I. tn. ω !! t = ω' t)  𝒫(ω in T' I. ω !! n = ω' n)"
      by (auto intro!: finite_measure_mono_AE simp: sets_T' sets_eq_imp_space_eq[OF sets_T'])
    ultimately have "𝒫(ω in T' I. ω !! n = ω' n)  0"
      by (auto simp: neq_iff not_less measure_le_0_iff) }
  note MC' = this

  show ?thesis
  proof
    show "countable U"
      unfolding U_def by (rule countable_reachable countable_Image countable_set_pmf)+
    show "t. (λω. ω !! t)  measurable (T' I) (count_space UNIV)"
      by (subst measurable_cong_sets[OF sets_T' refl]) simp
  next
    fix n
    have "xI. AE y in T x. (x ## y) !! n  U"
      unfolding U_def
    proof (induction n arbitrary: I)
      case 0 then show ?case
        by auto
    next
      case (Suc n)
      { fix x assume "x  I"
        have "AE y in T x. y !! n  (SIGMA x:UNIV. K x)* `` K x"
          apply (subst AE_T_iff)
          apply (rule measurable_compose[OF measurable_snth], simp)
          apply (rule Suc)
          done
        moreover have "(SIGMA x:UNIV. K x)* `` K x  (SIGMA x:UNIV. K x)* `` I"
          using x  I by (auto intro: converse_rtrancl_into_rtrancl)
        ultimately have "AE y in T x. y !! n  (SIGMA x:UNIV. K x)* `` I"
          by (auto simp: subset_eq) }
      then show ?case
        by simp
    qed
    then show "AE x in T' I. x !! n  U"
      by (simp add: AE_T')
  qed (simp_all add: TH MC MC')
qed

end

Theory Classifying_Markov_Chain_States

section ‹Classifying Markov Chain States›

theory Classifying_Markov_Chain_States
  imports
    "HOL-Computational_Algebra.Group_Closure"
    Discrete_Time_Markov_Chain
begin

lemma eventually_mult_Gcd:
  fixes S :: "nat set"
  assumes S: "s t. s  S  t  S  s + t  S"
  assumes s: "s  S" "s > 0"
  shows "eventually (λm. m * Gcd S  S) sequentially"
proof -
  define T where "T = insert 0 (int ` S)"
  with s S have "int s  T" "0  T" and T: "r  T  t  T  r + t  T" for r t
    by (auto simp del: of_nat_add simp add: of_nat_add [symmetric])
  have "Gcd T  group_closure T"
    by (rule Gcd_in_group_closure)
  also have "group_closure T = {s - t | s t. s  T  t  T}"
  proof (auto intro: group_closure.base group_closure.diff)
    fix x assume "x  group_closure T"
    then show "s t. x = s - t  s  T  t  T"
    proof induction
      case (base x) with 0  T show ?case
        apply (rule_tac x=x in exI)
        apply (rule_tac x=0 in exI)
        apply auto
        done
    next
      case (diff x y)
      then obtain a b c d where
        "a  T" "b  T" "x = a - b"
        "c  T" "d  T" "y = c - d"
        by auto
      then show ?case
        apply (rule_tac x="a + d" in exI)
        apply (rule_tac x="b + c" in exI)
        apply (auto intro: T)
        done
    qed
  qed
  finally obtain s' t' :: int
    where "s'  T" "t'  T" "Gcd T = s' - t'"
    by blast
  moreover define s and t where "s = nat s'" and "t = nat t'"
  moreover have "int (Gcd S) = - int t  S  {0}  t = 0"
    by auto (metis Gcd_dvd_nat dvd_0_right dvd_antisym nat_int nat_zminus_int) 
  ultimately have 
    st: "s = 0  s  S" "t = 0  t  S" and Gcd_S: "Gcd S = s - t"
    using T_def by safe simp_all
  with s
  have "t < s"
    by (rule_tac ccontr) auto

  { fix s n have "0 < n  s  S  n * s  S"
    proof (induct n)
      case (Suc n) then show ?case
        by (cases n) (auto intro: S)
    qed simp }
  note cmult_S = this

  show ?thesis
    unfolding eventually_sequentially
  proof cases
    assume "s = 0  t = 0"
    with st Gcd_S s have *: "Gcd S  S"
      by (auto simp: int_eq_iff)
    then show "N. nN. n * Gcd S  S" by (auto intro!: exI[of _ 1] cmult_S)
  next
    assume "¬ (s = 0  t = 0)"
    with st have "s  S" "t  S" "t  0" by auto
    then have "Gcd S dvd t" by auto
    then obtain a where a: "t = Gcd S * a" ..
    with t  0 have "0 < a" by auto

    show "N. nN. n * Gcd S  S"
    proof (safe intro!: exI[of _ "a * a"])
      fix n
      define m where "m = (n - a * a) div a"
      define r where "r = (n - a * a) mod a"
      with 0 < a have "r < a" by simp
      moreover define am where "am = a + m"
      ultimately have "r < am" by simp
      assume "a * a  n" then have n: "n = a * a + (m * a + r)"
        unfolding m_def r_def by simp
      have "n * Gcd S = am * t + r * Gcd S"
        unfolding n a by (simp add: field_simps am_def)
      also have " = r * s + (am - r) * t"
        unfolding ‹Gcd S = s - t
        using t < s r < am by (simp add: field_simps diff_mult_distrib2)
      also have "  S"
        using s  S t  S r < am
        by (cases "r = 0") (auto intro!: cmult_S S)
      finally show "n * Gcd S  S" .
    qed
  qed
qed

context MC_syntax
begin

subsection ‹Expected number of visits›

definition "G s t = (+ω. scount (HLD {t}) (s ## ω) T s)"

lemma G_eq: "G s t = (+ω. emeasure (count_space UNIV) {i. (s ## ω) !! i = t} T s)"
  by (simp add: G_def scount_eq_emeasure HLD_iff)

definition "p s t n = 𝒫(ω in T s. (s ## ω) !! n = t)"

definition "gf_G s t z = (n. p s t n *R z ^ n)"

definition "convergence_G s t z  summable (λn. p s t n * norm z ^ n)"

lemma p_nonneg[simp]: "0  p x y n"
  by (simp add: p_def)

lemma p_le_1: "p x y n  1"
  by (simp add: p_def)

lemma p_x_x_0[simp]: "p x x 0 = 1"
  by (simp add: p_def T.prob_space del: space_T)

lemma p_0: "p x y 0 = (if x = y then 1 else 0)"
  by (simp add: p_def T.prob_space del: space_T)

lemma p_in_reachable: assumes "(x, y)  (SIGMA x:UNIV. K x)*" shows "p x y n = 0"
  unfolding p_def
proof (rule T.prob_eq_0_AE)
  from AE_T_reachable show "AE ω in T x. (x ## ω) !! n  y"
  proof eventually_elim
    fix ω assume "alw (HLD ((SIGMA ω:UNIV. K ω)* `` {x})) ω"
    then have "alw (HLD (- {y})) ω"
      using assms by (auto intro: alw_mono simp: HLD_iff)
    then show "(x ## ω) !! n  y"
      using assms by (cases n) (auto simp: alw_HLD_iff_streams streams_iff_snth)
  qed
qed

lemma p_Suc: "ennreal (p x y (Suc n)) = (+ w. p w y n K x)"
  unfolding p_def T.emeasure_eq_measure[symmetric] by (subst emeasure_Collect_T) simp_all

lemma p_Suc':
  "p x y (Suc n) = (x'. p x' y n K x)"
  using p_Suc[of x y n]
  by (subst (asm) nn_integral_eq_integral)
     (auto simp: p_le_1 intro!: measure_pmf.integrable_const_bound[where B=1])

lemma p_add: "p x y (n + m) = (+ w. p x w n * p w y m count_space UNIV)"
proof (induction n arbitrary: x)
  case 0
  have [simp]: "w. (if x = w then 1 else 0) * p w y m = ennreal (p x y m) * indicator {x} w"
    by auto
  show ?case
    by (simp add: p_0 one_ennreal_def[symmetric] max_def)
next
  case (Suc n)
  define X where "X = (SIGMA x:UNIV. K x)* `` K x"
  then have X: "countable X"
    by (blast intro: countable_Image countable_reachable countable_set_pmf)

  then interpret X: sigma_finite_measure "count_space X"
    by (rule sigma_finite_measure_count_space_countable)
  interpret XK: pair_sigma_finite "K x" "count_space X"
    by unfold_locales

  have "ennreal (p x y (Suc n + m)) = (+t. (+w. p t w n * p w y m count_space UNIV) K x)"
    by (simp add: p_Suc Suc)
  also have " = (+t. (+w. ennreal (p t w n * p w y m) * indicator X w count_space UNIV) K x)"
    by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def             split: split_indicator)
  also have " = (+t. (+w. p t w n * p w y m count_space X) K x)"
    by (subst nn_integral_restrict_space[symmetric]) (simp_all add: restrict_count_space)
  also have " = (+w. (+t. p t w n * p w y m K x) count_space X)"
    apply (rule XK.Fubini'[symmetric])
    unfolding measurable_split_conv
    apply (rule measurable_compose_countable'[OF _ measurable_snd X])
    apply (rule measurable_compose[OF measurable_fst])
    apply simp
    done
  also have " = (+w. (+t. ennreal (p t w n * p w y m) * indicator X w K x) count_space UNIV)"
    by (simp add: nn_integral_restrict_space[symmetric] restrict_count_space nn_integral_multc)
  also have " = (+w. (+t. ennreal (p t w n * p w y m) K x) count_space UNIV)"
    by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def             split: split_indicator)
  also have " = (+w. (+t. p t w n K x) * p w y m count_space UNIV)"
    by (simp add: nn_integral_multc[symmetric] ennreal_mult)
  finally show ?case
    by (simp add: ennreal_mult p_Suc)
qed

lemma prob_reachable_le:
  assumes [simp]: "m  n"
  shows "p x y m * p y w (n - m)  p x w n"
proof -
  have "p x y m * p y w (n - m) = (+y'. ennreal (p x y m * p y w (n - m)) * indicator {y} y' count_space UNIV)"
    by simp
  also have "  p x w (m + (n - m))"
    by (subst p_add)
       (auto intro!: nn_integral_mono split: split_indicator simp del: nn_integral_indicator_singleton)
  finally show ?thesis
    by simp
qed

lemma G_eq_suminf: "G x y = (i. ennreal (p x y i))"
proof -
  have *: "i ω. indicator {ω  space S. (x ## ω) !! i = y} ω = indicator {i. (x ## ω) !! i = y} i"
    by (auto simp: space_stream_space split: split_indicator)

  have "G x y = (+ ω. (i. indicator {ωspace (T x). (x ## ω) !! i = y} ω) T x)"
    unfolding G_eq by (simp add: nn_integral_count_space_nat[symmetric] *)
  also have " = (i. ennreal (p x y i))"
    by (simp add: T.emeasure_eq_measure[symmetric] p_def nn_integral_suminf)
  finally show ?thesis .
qed

lemma G_eq_real_suminf:
  "convergence_G x y (1::real)  G x y = ennreal (i. p x y i)"
  unfolding G_eq_suminf
  by (intro suminf_ennreal ennreal_suminf_neq_top p_nonneg)
     (auto simp: convergence_G_def p_def)

lemma convergence_norm_G:
  "convergence_G x y z  summable (λn. p x y n * norm z ^ n)"
  unfolding convergence_G_def .

lemma convergence_G:
  "convergence_G x y (z::'a::{banach, real_normed_div_algebra})  summable (λn. p x y n *R z ^ n)"
  unfolding convergence_G_def
  by (rule summable_norm_cancel) (simp add: abs_mult norm_power)

lemma convergence_G_less_1:
  fixes z :: "_ :: {banach, real_normed_field}"
  assumes z: "norm z < 1" shows "convergence_G x y z"
  unfolding convergence_G_def
proof (rule summable_comparison_test)
  have "n. p x y n * norm (z ^ n)  1 * norm (z ^ n)"
    by (intro mult_right_mono p_le_1) simp_all
  then show "N. nN. norm (p x y n * norm z ^ n)  norm z ^ n"
    by (simp add: norm_power)
qed (simp add: z summable_geometric)

lemma lim_gf_G: "((λz. ennreal (gf_G x y z))  G x y) (at_left (1::real))"
  unfolding gf_G_def G_eq_suminf real_scaleR_def
  by (intro power_series_tendsto_at_left p_nonneg p_le_1 summable_power_series)

subsection ‹Reachability probability›

definition "u x y n = 𝒫(ω in T x. ev_at (HLD {y}) n ω)"

definition "U s t = 𝒫(ω in T s. ev (HLD {t}) ω)"

definition "gf_U x y z = (n. u x y n *R z ^ Suc n)"

definition "f x y n = 𝒫(ω in T x. ev_at (HLD {y}) n (x ## ω))"

definition "F s t = 𝒫(ω in T s. ev (HLD {t}) (s ## ω))"

definition "gf_F x y z = (n. f x y n * z ^ n)"

lemma f_Suc: "x  y  f x y (Suc n) = u x y n"
  by (simp add: u_def f_def)

lemma f_Suc_eq: "f x x (Suc n) = 0"
  by (simp add: f_def)

lemma f_0: "f x y 0 = (if x = y then 1 else 0)"
  using T.prob_space by (simp add: f_def)

lemma shows u_nonneg: "0  u x y n" and u_le_1: "u x y n  1"
  by (simp_all add: u_def)

lemma shows f_nonneg: "0  f x y n" and f_le_1: "f x y n  1"
  by (simp_all add: f_def)

lemma U_nonneg[simp]: "0  U x y"
  by (simp add: U_def)

lemma U_le_1: "U s t  1"
  by (auto simp add: U_def intro!: antisym)

lemma U_cases: "U s s = 1  U s s < 1"
  by (auto simp add: U_def intro!: antisym)

lemma u_sums_U: "u x y sums U x y"
  unfolding u_def[abs_def] U_def ev_iff_ev_at by (intro T.prob_sums) (auto intro: ev_at_unique)

lemma gf_U_eq_U: "gf_U x y 1 = U x y"
  using u_sums_U[THEN sums_unique] by (simp add: gf_U_def U_def)

lemma f_sums_F: "f x y sums F x y"
  unfolding f_def[abs_def] F_def ev_iff_ev_at
  by (intro T.prob_sums) (auto intro: ev_at_unique)

lemma F_nonneg[simp]: "0  F x y"
  by (auto simp: F_def)

lemma F_le_1: "F x y  1"
  by (simp add: F_def)

lemma gf_F_eq_F: "gf_F x y 1 = F x y"
  using f_sums_F[THEN sums_unique] by (simp add: gf_F_def F_def)

lemma gf_F_le_1:
  fixes z :: real
  assumes z: "0  z" "z  1"
  shows "gf_F x y z  1"
proof -
  have "gf_F x y z  gf_F x y 1"
    using z unfolding gf_F_def
    by (intro suminf_le[OF _ summable_comparison_test[OF _ sums_summable[OF f_sums_F[of x y]]]] mult_left_mono allI f_nonneg)
       (simp_all add: power_le_one f_nonneg mult_right_le_one_le f_le_1 sums_summable[OF f_sums_F[of x y]])
  also have "  1"
    by (simp add: gf_F_eq_F F_def)
  finally show ?thesis .
qed

lemma u_le_p: "u x y n  p x y (Suc n)"
  unfolding u_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)

lemma f_le_p: "f x y n  p x y n"
  unfolding f_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)

lemma convergence_norm_U:
  fixes z :: "_ :: real_normed_div_algebra"
  assumes z: "convergence_G x y z"
  shows "summable (λn. u x y n * norm z ^ Suc n)"
  using summable_ignore_initial_segment[OF convergence_norm_G[OF z], of 1]
  by (rule summable_comparison_test[rotated])
     (auto simp add: u_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono u_le_p)

lemma convergence_norm_F:
  fixes z :: "_ :: real_normed_div_algebra"
  assumes z: "convergence_G x y z"
  shows "summable (λn. f x y n * norm z ^ n)"
  using convergence_norm_G[OF z]
  by (rule summable_comparison_test[rotated])
     (auto simp add: f_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono f_le_p)

lemma gf_G_nonneg:
  fixes z :: real
  shows "0  z  z < 1  0  gf_G x y z"
  unfolding gf_G_def
  by (intro suminf_nonneg convergence_G convergence_G_less_1) simp_all

lemma gf_F_nonneg:
  fixes z :: real
  shows "0  z  z < 1  0  gf_F x y z"
  unfolding gf_F_def
  using convergence_norm_F[OF convergence_G_less_1, of z x y]
  by (intro suminf_nonneg) (simp_all add: f_nonneg)

lemma convergence_U:
  fixes z :: "_ :: banach"
  shows "convergence_G x y z  summable (λn. u x y n * z ^ Suc n)"
  by (rule summable_norm_cancel)
     (auto simp add: abs_mult u_nonneg power_abs dest!: convergence_norm_U)

lemma p_eq_sum_p_u: "p x y (Suc n) = (in. p y y (n - i) * u x y i)"
proof -
  have "ω. ω !! n = y  (i. i  n  ev_at (HLD {y}) i ω)"
  proof (induction n)
    case (Suc n)
    then obtain i where "i  n" "ev_at (HLD {y}) i (stl ω)"
      by auto
    then show ?case
      by (auto intro!: exI[of _ "if HLD {y} ω then 0 else Suc i"])
  qed (simp add: HLD_iff)
  then have "p x y (Suc n) = (in. 𝒫(ω in T x. ev_at (HLD {y}) i ω  ω !! n = y))"
    unfolding p_def by (intro T.prob_sum) (auto intro: ev_at_unique)
  also have " = (in. p y y (n - i) * u x y i)"
  proof (intro sum.cong refl)
    fix i assume i: "i  {.. n}"
    then have "ω. (Suc i  n  ω !! (n - Suc i) = y)  ((y ## ω) !! (n - i) = y)"
      by (auto simp: Stream_snth diff_Suc split: nat.split)
    from i have "i  n" by auto
    then have "𝒫(ω in T x. ev_at (HLD {y}) i ω  ω !! n = y) =
      (ω'. 𝒫(ω in T y. (y ## ω) !! (n - i) = y) *
        indicator {ω'space (T x). ev_at (HLD {y}) i ω' } ω' T x)"
      by (subst prob_T_split[where n="Suc i"])
         (auto simp: ev_at_shift ev_at_HLD_single_imp_snth shift_snth diff_Suc
               split: split_indicator nat.split intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure]
               simp del: stake.simps integral_mult_right_zero)
    then show "𝒫(ω in T x. ev_at (HLD {y}) i ω  ω !! n = y) = p y y (n - i) * u x y i"
      by (simp add: p_def u_def)
  qed
  finally show ?thesis .
qed

lemma p_eq_sum_p_f: "p x y n = (in. p y y (n - i) * f x y i)"
  by (cases n)
     (simp_all del: sum.atMost_Suc
               add: f_0 p_0 p_eq_sum_p_u atMost_Suc_eq_insert_0 zero_notin_Suc_image sum.reindex
                    f_Suc f_Suc_eq)

lemma gf_G_eq_gf_F:
  assumes z: "norm z < 1"
  shows "gf_G x y z = gf_F x y z * gf_G y y z"
proof -
  have "gf_G x y z = (n. in. p y y (n - i) * f x y i * z^n)"
    by (simp add: gf_G_def p_eq_sum_p_f[of x y] sum_distrib_right)
  also have " = (n. in. (f x y i * z^i) * (p y y (n - i) * z^(n - i)))"
    by (intro arg_cong[where f=suminf] sum.cong ext atLeast0AtMost[symmetric])
       (simp_all add: power_add[symmetric])
  also have " = (n. f x y n * z^n) * (n. p y y n * z^n)"
    using convergence_norm_F[OF convergence_G_less_1[OF z]] convergence_norm_G[OF convergence_G_less_1[OF z]]
    by (intro Cauchy_product[symmetric]) (auto simp: f_nonneg abs_mult power_abs)
  also have " = gf_F x y z * gf_G y y z"
    by (simp add: gf_F_def gf_G_def)
  finally show ?thesis .
qed

lemma gf_G_eq_gf_U:
  fixes z :: "'z :: {banach, real_normed_field}"
  assumes z: "convergence_G x x z"
  shows "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z  1"
proof -
  { fix n
    have "p x x (Suc n) *R z^Suc n = (in. (p x x (n - i) * u x x i) *R z^Suc n)"
      unfolding scaleR_sum_left[symmetric] by (simp add: p_eq_sum_p_u)
    also have " = (in. (u x x i *R z^Suc i) * (p x x (n - i) *R z^(n - i)))"
      by (intro sum.cong refl) (simp add: field_simps power_diff cong: disj_cong)
    finally have "p x x (Suc n) *R z^(Suc n) = (in. (u x x i *R z^Suc i) * (p x x (n - i) *R z^(n - i)))"
      unfolding atLeast0AtMost . }
  note gfs_Suc_eq = this

  have "gf_G x x z = 1 + (n. p x x (Suc n) *R z^(Suc n))"
    unfolding gf_G_def
    by (subst suminf_split_initial_segment[OF convergence_G[OF z], of 1]) simp
  also have " = 1 + (n. in. (u x x i *R z^Suc i) * (p x x (n - i) *R z^(n - i)))"
    unfolding gfs_Suc_eq ..
  also have " = 1 + gf_U x x z * gf_G x x z"
    unfolding gf_U_def gf_G_def
    by (subst Cauchy_product)
       (auto simp: u_nonneg norm_power simp del: power_Suc
             intro!: z convergence_norm_G convergence_norm_U)
  finally show "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z  1"
    apply -
    apply (cases "gf_U x x z = 1")
    apply (auto simp add: field_simps)
    done
qed

lemma gf_U: "(gf_U x y  U x y) (at_left 1)"
proof -
  have "((λz. ennreal (n. u x y n * z ^ n))  (n. ennreal (u x y n))) (at_left 1)"
    using u_le_1 u_nonneg by (intro power_series_tendsto_at_left summable_power_series)
  also have "(n. ennreal (u x y n)) = ennreal (suminf (u x y))"
    by (intro u_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF u_sums_U])
  also have "suminf (u x y) = U x y"
    using u_sums_U by (rule sums_unique[symmetric])
  finally have "((λz. n. u x y n * z ^ n)  U x y) (at_left 1)"
    by (rule tendsto_ennrealD)
       (auto simp: u_nonneg u_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
  then have "((λz. z * (n. u x y n * z ^ n))  1 * U x y) (at_left 1)"
    by (intro tendsto_intros) simp
  then have "((λz. n. u x y n * z ^ Suc n)  1 * U x y) (at_left 1)"
    apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
    apply (rule eventually_at_left_1)
    apply (subst suminf_mult[symmetric])
    apply (auto intro!: summable_power_series u_le_1 u_nonneg)
    apply (simp add: field_simps)
    done
  then show ?thesis
    by (simp add: gf_U_def[abs_def] U_def)
qed

lemma gf_U_le_1: assumes z: "0 < z" "z < 1" shows "gf_U x y z  (1::real)"
proof -
  note u = u_sums_U[of x y, THEN sums_summable]
  have "gf_U x y z  gf_U x y 1"
    using z
    unfolding gf_U_def real_scaleR_def
    by (intro suminf_le allI mult_mono power_mono summable_comparison_test_ev[OF _ u] always_eventually)
       (auto simp: u_nonneg intro!: mult_left_le mult_le_one power_le_one)
  also have "  1"
    unfolding gf_U_eq_U by (rule U_le_1)
  finally show ?thesis .
qed

lemma gf_F: "(gf_F x y  F x y) (at_left 1)"
proof -
  have "((λz. ennreal (n. f x y n * z ^ n))  (n. ennreal (f x y n))) (at_left 1)"
    using f_le_1 f_nonneg by (intro power_series_tendsto_at_left summable_power_series)
  also have "(n. ennreal (f x y n)) = ennreal (suminf (f x y))"
    by (intro f_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF f_sums_F])
  also have "suminf (f x y) = F x y"
    using f_sums_F by (rule sums_unique[symmetric])
  finally have "((λz. n. f x y n * z ^ n)  F x y) (at_left 1)"
    by (rule tendsto_ennrealD)
       (auto simp: f_nonneg f_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
  then show ?thesis
    by (simp add: gf_F_def[abs_def] F_def)
qed

lemma U_bounded: "0  U x y" "U x y  1"
  unfolding U_def by simp_all

subsection ‹Recurrent states›

definition recurrent :: "'s  bool" where
  "recurrent s  (AE ω in T s. ev (HLD {s}) ω)"

lemma recurrent_iff_U_eq_1: "recurrent s  U s s = 1"
    unfolding recurrent_def U_def by (subst T.prob_Collect_eq_1) simp_all

definition "H s t = 𝒫(ω in T s. alw (ev (HLD {t})) ω)"

lemma H_eq:
  "recurrent s  H s s = 1"
  "¬ recurrent s  H s s = 0"
  "H s t = U s t * H t t"
proof -
  define H' where "H' t n = {ωspace S. enat n  scount (HLD {t::'s}) ω}" for t n
  have [measurable]: "y n. H' y n  sets S"
    by (simp add: H'_def)
  let ?H' = "λs t n. measure (T s) (H' t n)"
  { fix x y :: 's and ω
    have "Suc 0  scount (HLD {y}) ω  ev (HLD {y}) ω"
      using scount_eq_0_iff[of "HLD {y}" ω]
      by (cases "scount (HLD {y}) ω" rule: enat_coexhaust)
         (auto simp: not_ev_iff[symmetric] eSuc_enat[symmetric] enat_0 HLD_iff[abs_def]) }
  then have H'_1: "x y. ?H' x y 1 = U x y"
    unfolding H'_def U_def by simp

  { fix n and x y :: 's
    let ?U = "(not (HLD {y}) suntil (HLD {y} aand nxt (λω. enat n  scount (HLD {y}) ω)))"
    { fix ω
      have "enat (Suc n)  scount (HLD {y}) ω  ?U ω"
      proof
        assume "enat (Suc n)  scount (HLD {y}) ω"
        with scount_eq_0_iff[of "HLD {y}" ω] have "ev (HLD {y}) ω" "enat (Suc n)  scount (HLD {y}) ω"
          by (auto simp add: not_ev_iff[symmetric] eSuc_enat[symmetric])
        then show "?U ω"
          by (induction rule: ev_induct_strong)
             (auto simp: scount_simps eSuc_enat[symmetric] intro: suntil.intros)
      next
        assume "?U ω" then show "enat (Suc n)  scount (HLD {y}) ω"
          by induction (auto simp: scount_simps  eSuc_enat[symmetric])
      qed }
    then have "emeasure (T x) (H' y (Suc n)) = emeasure (T x) {ωspace (T x). ?U ω}"
      by (simp add: H'_def)
    also have " = U x y * ?H' y y n"
      by (subst emeasure_suntil_HLD) (simp_all add: T.emeasure_eq_measure U_def H'_def ennreal_mult)
    finally have "?H' x y (Suc n) = U x y * ?H' y y n"
      by (simp add: T.emeasure_eq_measure) }
  note H'_Suc = this

  { fix m and x :: 's
    have "?H' x x (Suc m) = U x x^Suc m"
      using H'_1 H'_Suc by (induct m) auto }
  note H'_eq = this

  { fix x y
    have "?H' x y  measure (T x) (i. H' y i)"
      apply (rule T.finite_Lim_measure_decseq)
      apply safe
      apply simp
      apply (auto simp add: decseq_Suc_iff subset_eq H'_def eSuc_enat[symmetric]
                  intro: ile_eSuc order_trans)
      done
    also have "(i. H' y i) = {ωspace (T x). alw (ev (HLD {y})) ω}"
      by (auto simp: H'_def scount_infinite_iff[symmetric]) (metis Suc_ile_eq enat.exhaust neq_iff)
    finally have "?H' x y  H x y"
      unfolding H_def . }
  note H'_lim = this

  from H'_lim[of s s, THEN LIMSEQ_Suc]
  have "(λn. U s s ^ Suc n)  H s s"
    by (simp add: H'_eq)
  then have lim_H: "(λn. U s s ^ n)  H s s"
    by (rule LIMSEQ_imp_Suc)

  have "U s s < 1  (λn. U s s ^ n)  0"
    by (rule LIMSEQ_realpow_zero) (simp_all add: U_def)
  with lim_H have "U s s < 1  H s s = 0"
    by (blast intro: LIMSEQ_unique)
  moreover have "U s s = 1  (λn. U s s ^ n)  1"
    by simp
  with lim_H have "U s s = 1  H s s = 1"
    by (blast intro: LIMSEQ_unique)
  moreover note recurrent_iff_U_eq_1 U_cases
  ultimately show "recurrent s  H s s = 1" "¬ recurrent s  H s s = 0"
    by (metis one_neq_zero)+

  from H'_lim[of s t, THEN LIMSEQ_Suc] H'_Suc[of s]
  have "(λn. U s t * ?H' t t n)  H s t"
    by simp
  moreover have "(λn. U s t * ?H' t t n)  U s t * H t t"
    by (intro tendsto_intros H'_lim)
  ultimately show "H s t = U s t * H t t"
    by (blast intro: LIMSEQ_unique)
qed

lemma recurrent_iff_G_infinite: "recurrent x  G x x = "
proof -
  have "((λz. ennreal (gf_G x x z))  G x x) (at_left 1)"
    by (rule lim_gf_G)
  then have G: "((λz. ennreal (1 / (1 - gf_U x x z)))  G x x) (at_left (1::real))"
    apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
    apply (rule eventually_at_left_1)
    apply (subst gf_G_eq_gf_U)
    apply (rule convergence_G_less_1)
    apply simp
    apply simp
    done

  { fix z :: real assume z: "0 < z" "z < 1"
    have 1: "summable (u x x)"
      using u_sums_U by (rule sums_summable)
    have "gf_U x x z  1"
      using gf_G_eq_gf_U[OF convergence_G_less_1[of z]] z by simp
    moreover
    have "gf_U x x z  U x x"
      unfolding gf_U_def gf_U_eq_U[symmetric]
      using z
      by (intro suminf_le)
         (auto simp add: 1 convergence_U convergence_G_less_1 u_nonneg simp del: power_Suc
               intro!: mult_right_le_one_le power_le_one)
    ultimately have "gf_U x x z < 1"
      using U_bounded[of x x] by simp }
  note strict = this

  { assume "U x x = 1"
    moreover have "((λxa. 1 - gf_U x x xa :: real)  1 - U x x) (at_left 1)"
      by (intro tendsto_intros gf_U)
    moreover have "eventually (λz. gf_U x x z < 1) (at_left (1::real))"
      by (auto intro!: eventually_at_left_1 strict simp: ‹U x x = 1 gf_U_eq_U)
    ultimately have "((λz. ennreal (1 / (1 - gf_U x x z)))  top) (at_left 1)"
      unfolding ennreal_tendsto_top_eq_at_top
      by (intro LIM_at_top_divide[where a=1] tendsto_const zero_less_one)
         (auto simp: field_simps)
    with G have "G x x = top"
      by (rule tendsto_unique[rotated]) simp }
  moreover
  { assume "U x x < 1"
    then have "((λxa. ennreal (1 / (1 - gf_U x x xa)))  1 / (1 - U x x)) (at_left 1)"
      by (intro tendsto_intros gf_U tendsto_ennrealI) simp
    from tendsto_unique[OF _ G this] have "G x x  "
      by simp }
  ultimately show ?thesis
    using U_cases recurrent_iff_U_eq_1 by auto
qed

definition communicating :: "('s × 's) set" where
  "communicating = acc  acc¯"

definition essential_class :: "'s set  bool" where
  "essential_class C  C  UNIV // communicating  acc `` C  C"

lemma accI_U:
  assumes "0 < U x y" shows "(x, y)  acc"
proof (rule ccontr)
  assume *: "(x, y)  acc"

  { fix ω assume "ev (HLD {y}) ω" "alw (HLD (acc `` {x})) ω" from this * have False
      by induction (auto simp: HLD_iff) }
  with AE_T_reachable[of x] have "U x y = 0"
    unfolding U_def by (intro T.prob_eq_0_AE) auto
  with 0 < U x y show False by auto
qed

lemma accD_pos:
  assumes "(x, y)  acc"
  shows "n. 0 < p x y n"
using assms proof induction
  case base with T.prob_space[of x] show ?case
    by (auto intro!: exI[of _ 0])
next
  have [simp]: "x y. (if x = y then 1 else 0::real) = indicator {y} x"
    by simp
  case (step w y)
  then obtain n where "0 < p x w n" and "0 < pmf (K w) y"
    by (auto simp: set_pmf_iff less_le)
  then have "0 < p x w n * pmf (K w) y"
    by (intro mult_pos_pos)
  also have "  p x w n * p w y (Suc 0)"
    by (simp add: p_Suc' p_0 pmf.rep_eq)
  also have "  p x y (Suc n)"
    using prob_reachable_le[of n "Suc n" x w y] by simp
  finally show ?case ..
qed

lemma accI_pos: "0 < p x y n  (x, y)  acc"
proof (induct n arbitrary: x)
  case (Suc n)
  then have less: "0 < (x'. p x' y n K x)"
    by (simp add: p_Suc')
  have "x'K x. 0 < p x' y n"
  proof (rule ccontr)
    assume "¬ ?thesis"
    then have "AE x' in K x. p x' y n = 0"
      by (simp add: AE_measure_pmf_iff less_le)
    then have "(x'. p x' y n K x) = (x'. 0 K x)"
      by (intro integral_cong_AE) simp_all
    with less show False by simp
  qed
  with Suc show ?case
    by (auto intro: converse_rtrancl_into_rtrancl)
qed (simp add: p_0 split: if_split_asm)

lemma recurrent_iffI_communicating:
  assumes "(x, y)  communicating"
  shows "recurrent x  recurrent y"
proof -
  from assms obtain n m where "0 < p x y n" "0 < p y x m"
    by (force simp: communicating_def dest: accD_pos)
  moreover
  { fix x y n m assume "0 < p x y n" "0 < p y x m" "G y y = "
    then have " = ennreal (p x y n * p y x m) * G y y"
      by (auto intro: mult_pos_pos simp: ennreal_mult_top)
    also have "ennreal (p x y n * p y x m) * G y y = (i. ennreal (p x y n * p y x m) * p y y i)"
      unfolding G_eq_suminf by (rule ennreal_suminf_cmult[symmetric])
    also have "  (i. ennreal (p x x (n + i + m)))"
    proof (intro suminf_le allI)
      fix i
      have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i))  p x y (n + i) * p y x ((n + i + m) - (n + i))"
        by (intro mult_right_mono prob_reachable_le) simp_all
      also have "  p x x (n + i + m)"
         by (intro prob_reachable_le) simp_all
      finally show "ennreal (p x y n * p y x m) * p y y i  ennreal (p x x (n + i + m))"
        by (simp add: ac_simps ennreal_mult'[symmetric])
    qed auto
    also have "  (i. ennreal (p x x (i + (n + m))))"
      by (simp add: ac_simps)
    also have "  (i. ennreal (p x x i))"
      by (subst suminf_offset[of "λi. ennreal (p x x i)" "n + m"]) auto
    also have "  G x x"
      unfolding G_eq_suminf by (auto intro!: suminf_le_pos)
    finally have "G x x = "
      by (simp add: top_unique) }
  ultimately show ?thesis
    using recurrent_iff_G_infinite by blast
qed

lemma recurrent_acc:
  assumes "recurrent x" "(x, y)  acc"
  shows "U y x = 1" "H y x = 1" "recurrent y" "(x, y)  communicating"
proof -
  { fix w y assume step: "(x, w)  acc" "y  K w" "U w x = 1" "H w x = 1" "recurrent w" "x  y"
    have "measure (K w) UNIV = U w x"
      using step measure_pmf.prob_space[of "K w"] by simp
    also have " = (v. indicator {x} v + U v x * indicator (- {x}) v K w)"
      unfolding U_def
      by (subst prob_T)
         (auto intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure] AE_I2
               simp: ev_Stream T.prob_eq_1 split: split_indicator)
    also have " = measure (K w) {x} + (v. U v x * indicator (- {x}) v K w)"
      by (subst Bochner_Integration.integral_add)
         (auto intro!: measure_pmf.integrable_const_bound[where B=1]
               simp: abs_mult mult_le_one U_bounded(2) measure_pmf.emeasure_eq_measure)
    finally have "measure (K w) UNIV - measure (K w) {x} = (v. U v x * indicator (- {x}) v K w)"
      by simp
    also have "measure (K w) UNIV - measure (K w) {x} = measure (K w) (UNIV - {x})"
      by (subst measure_pmf.finite_measure_Diff) auto
    finally have "0 = (v. indicator (- {x}) v K w) - (v. U v x * indicator (- {x}) v K w)"
      by (simp add: measure_pmf.emeasure_eq_measure Compl_eq_Diff_UNIV)
    also have " = (v. (1 - U v x) * indicator (- {x}) v K w)"
      by (subst Bochner_Integration.integral_diff[symmetric])
         (auto intro!: measure_pmf.integrable_const_bound[where B=1] Bochner_Integration.integral_cong
               simp: abs_mult mult_le_one U_bounded(2) split: split_indicator)
    also have "  (v. (1 - U y x) * indicator {y} v K w)" (is "_  ?rhs")
      using ‹recurrent x
      by (intro integral_mono measure_pmf.integrable_const_bound[where B=1])
         (auto simp: abs_mult mult_le_one U_bounded(2) recurrent_iff_U_eq_1 field_simps
               split: split_indicator)
    also (xtrans) have "?rhs = (1 - U y x) * pmf (K w) y"
      by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)
    finally have "(1 - U y x) * pmf (K w) y = 0"
      by (auto intro!: antisym simp: U_bounded(2) mult_le_0_iff)
    with y  K w have "U y x = 1"
      by (simp add: set_pmf_iff)
    then have "U y x = 1" "H y x = 1"
      using H_eq(3)[of y x] H_eq(1)[of x] by (simp_all add: ‹recurrent x)
    then have "(y, x)  acc"
      by (intro accI_U) auto
    with step have "(x, y)  communicating"
      by (auto simp add: communicating_def intro: rtrancl_trans)
    with ‹recurrent x have "recurrent y"
      by (simp add: recurrent_iffI_communicating)
    note this ‹U y x = 1 ‹H y x = 1 (x, y)  communicating› }
  note enabled = this

  from (x, y)  acc›
  show "U y x = 1" "H y x = 1" "recurrent y" "(x, y)  communicating"
  proof induction
    case base then show "U x x = 1" "H x x = 1" "recurrent x" "(x, x)  communicating"
      using ‹recurrent x H_eq(1)[of x] by (auto simp: recurrent_iff_U_eq_1 communicating_def)
  next
    case (step w y)
    with enabled[of w y] ‹recurrent x H_eq(1)[of x]
    have "U y x = 1  H y x = 1  recurrent y  (x, y)  communicating"
      by (cases "x = y") (auto simp: recurrent_iff_U_eq_1 communicating_def)
    then show "U y x = 1" "H y x = 1" "recurrent y" "(x, y)  communicating"
      by auto
  qed
qed

lemma equiv_communicating: "equiv UNIV communicating"
  by (auto simp: equiv_def sym_def communicating_def refl_on_def trans_def)

lemma recurrent_class:
  assumes "recurrent x"
  shows "acc `` {x} = communicating `` {x}"
  using recurrent_acc(4)[OF ‹recurrent x] by (auto simp: communicating_def)

lemma irreduccible_recurrent_class:
  assumes "recurrent x" shows "acc `` {x}  UNIV // communicating"
  unfolding recurrent_class[OF ‹recurrent x] by (rule quotientI) simp

lemma essential_classI:
  assumes C: "C  UNIV // communicating"
  assumes eq: "x y. x  C  (x, y)  acc  y  C"
  shows "essential_class C"
  by (auto simp: essential_class_def intro: C) (metis eq)

lemma essential_recurrent_class:
  assumes "recurrent x" shows "essential_class (communicating `` {x})"
  unfolding recurrent_class[OF ‹recurrent x, symmetric]
  apply (rule essential_classI)
  apply (rule irreduccible_recurrent_class[OF assms])
  apply (auto simp: communicating_def)
  done

lemma essential_classD2:
  "essential_class C  x  C  (x, y)  acc  y  C"
  unfolding essential_class_def by auto

lemma essential_classD3:
  "essential_class C  x  C  y  C  (x, y)  communicating"
  unfolding essential_class_def
  by (auto elim!: quotientE simp: communicating_def)

lemma AE_acc:
  shows "AE ω in T x. m. (x, (x ## ω) !! m)  acc"
  using AE_T_reachable
  by eventually_elim (auto simp: alw_HLD_iff_streams streams_iff_snth Stream_snth split: nat.splits)

lemma finite_essential_class_imp_recurrent:
  assumes C: "essential_class C" "finite C" and x: "x  C"
  shows "recurrent x"
proof -
  have "AE ω in T x. yC. alw (ev (HLD {y})) ω"
    using AE_T_reachable
  proof eventually_elim
    fix ω assume "alw (HLD (acc `` {x})) ω"
    then have "alw (HLD C) ω"
      by (rule alw_mono) (auto simp: HLD_iff intro: assms essential_classD2)
    then show "yC. alw (ev (HLD {y})) ω"
      by (rule pigeonhole_stream) fact
  qed
  then have "1 = 𝒫(ω in T x. yC. alw (ev (HLD {y})) ω)"
    by (subst (asm) T.prob_Collect_eq_1[symmetric]) (auto simp: ‹finite C)
  also have " = measure (T x) (yC. {ωspace (T x). alw (ev (HLD {y})) ω})"
    by (intro arg_cong2[where f=measure]) auto
  also have "  (yC. H x y)"
    unfolding H_def using ‹finite C by (rule T.finite_measure_subadditive_finite) auto
  also have " = (yC. U x y * H y y)"
    by (auto intro!: sum.cong H_eq)
  finally have "yC. recurrent y"
    by (rule_tac ccontr) (simp add: H_eq(2))
  then guess y ..
  from essential_classD3[OF C(1) x this(1)] recurrent_acc(3)[OF this(2)]
  show "recurrent x"
    by (simp add: communicating_def)
qed

lemma irreducibleD:
  "C  UNIV // communicating  a  C  b  C  (a, b)  communicating"
  by (auto elim!: quotientE simp: communicating_def)

lemma irreducibleD2:
  "C  UNIV // communicating  a  C  (a, b)  communicating  b  C"
  by (auto elim!: quotientE simp: communicating_def)

lemma essential_class_iff_recurrent:
  "finite C  C  UNIV // communicating  essential_class C  (xC. recurrent x)"
  by (metis finite_essential_class_imp_recurrent irreducibleD2 recurrent_acc(4) essential_classI)

definition "U' x y = (+ω. eSuc (sfirst (HLD {y}) ω) T x)"

lemma U'_neq_zero[simp]: "U' x y  0"
  unfolding U'_def by (simp add: nn_integral_add)

definition "gf_U' x y z = (n. u x y n * Suc n * z ^ n)"

definition "pos_recurrent x  recurrent x  U' x x  "

lemma summable_gf_U':
  assumes z: "norm z < 1"
  shows "summable (λn. u x y n * Suc n * z ^ n)"
proof -
  have "summable (λn. n * ¦z¦ ^ n)"
  proof (rule root_test_convergence)
    have "(λn. root n n * ¦z¦)  1 * ¦z¦"
      by (intro tendsto_intros LIMSEQ_root)
    then show "(λn. root n (norm (n * ¦z¦ ^ n)))  ¦z¦"
      by (rule filterlim_cong[THEN iffD1, rotated 3])
         (auto intro!: exI[of _ 1]
               simp add: abs_mult u_nonneg real_root_mult power_abs eventually_sequentially real_root_power)
  qed (insert z, simp add: abs_less_iff)
  note summable_mult[OF this, of "1 / ¦z¦"]
  from summable_ignore_initial_segment[OF this, of 1]
  show "summable (λn. u x y n * Suc n * z ^ n)"
    apply (rule summable_comparison_test[rotated])
    using z
    apply (auto intro!: exI[of _ 1]
                simp: abs_mult u_nonneg power_abs Suc_le_eq gr0_conv_Suc field_simps le_divide_eq u_le_1
                simp del: of_nat_Suc)
    done
qed

lemma gf_U'_nonneg[simp]: "0 < z  z < 1  0  gf_U' x y z"
  unfolding gf_U'_def
  by (intro suminf_nonneg summable_gf_U') (auto simp: u_nonneg)

lemma DERIV_gf_U:
  fixes z :: real assumes z: "0 < z" "z < 1"
  shows "DERIV (gf_U x y) z :> gf_U' x y z"
  unfolding gf_U_def[abs_def]  gf_U'_def real_scaleR_def u_def[symmetric]
  using z by (intro DERIV_power_series'[where R=1] summable_gf_U') auto

lemma sfirst_finiteI_recurrent:
  "recurrent x  (x, y)  acc  AE ω in T x. sfirst (HLD {y}) ω < "
  using recurrent_acc(1)[of y x] recurrent_acc[of x y]
    T.AE_prob_1[of x "{ωspace (T x). ev (HLD {y}) ω}"]
  unfolding sfirst_finite U_def by (simp add: space_stream_space communicating_def)

lemma U'_eq_suminf:
  assumes x: "recurrent x" "(x, y)  acc"
  shows "U' x y = (i. ennreal (u x y i * Suc i))"
proof -
  have "(+ω. eSuc (sfirst (HLD {y}) ω) T x) =
      (+ω. (i. ennreal (Suc i) * indicator {ωspace (T y). ev_at (HLD {y}) i ω} ω) T x)"
    using sfirst_finiteI_recurrent[OF x]
  proof (intro nn_integral_cong_AE, eventually_elim)
    fix ω assume "sfirst (HLD {y}) ω < "
    then obtain n :: nat where [simp]: "sfirst (HLD {y}) ω = n"
      by auto
    show "eSuc (sfirst (HLD {y}) ω) = (i. ennreal (Suc i) * indicator {ωspace (T y). ev_at (HLD {y}) i ω} ω)"
      by (subst suminf_cmult_indicator[where i=n])
         (auto simp: disjoint_family_on_def ev_at_unique space_stream_space
                     sfirst_eq_enat_iff[symmetric] ennreal_of_nat_eq_real_of_nat
               split: split_indicator)
  qed
  also have " = (i. ennreal (Suc i) * emeasure (T x) {ωspace (T x). ev_at (HLD {y}) i ω})"
    by (subst nn_integral_suminf)
       (auto intro!: arg_cong[where f=suminf] nn_integral_cmult_indicator simp: fun_eq_iff)
  finally show ?thesis
    by (simp add: U'_def u_def T.emeasure_eq_measure mult_ac ennreal_mult)
qed

lemma gf_U'_tendsto_U':
  assumes x: "recurrent x" "(x, y)  acc"
  shows "((λz. ennreal (gf_U' x y z))  U' x y) (at_left 1)"
  unfolding U'_eq_suminf[OF x] gf_U'_def
  by (auto intro!: power_series_tendsto_at_left summable_gf_U' mult_nonneg_nonneg u_nonneg simp del: of_nat_Suc)

lemma one_le_integral_t:
  assumes x: "recurrent x" shows "1  U' x x"
  by (simp add: nn_integral_add T.emeasure_space_1 U'_def del: space_T)

lemma gf_U'_pos:
  fixes z :: real
  assumes z: "0 < z" "z < 1" and "U x y  0"
  shows "0 < gf_U' x y z"
  unfolding gf_U'_def
proof (subst suminf_pos_iff)
  show "summable (λn. u x y n * real (Suc n) * z ^ n)"
    using z by (intro summable_gf_U') simp
  show pos: "n. 0  u x y n * real (Suc n) * z ^ n"
    using u_nonneg z by auto
  show "n. 0 < u x y n * real (Suc n) * z ^ n"
  proof (rule ccontr)
    assume "¬ (n. 0 < u x y n * real (Suc n) * z ^ n)"
    with pos have "n. u x y n * real (Suc n) * z ^ n = 0"
      by (intro antisym allI) (simp_all add: not_less)
    with z have "u x y = (λn. 0)"
      by (intro ext) simp
    with u_sums_U[of x y, THEN sums_unique] ‹U x y  0 show False
      by simp
  qed
qed

lemma inverse_gf_U'_tendsto:
  assumes "recurrent y"
  shows "((λx. - 1 / - gf_U' y y x)  enn2real (1 / U' y y)) (at_left (1::real))"
proof cases
  assume inf: "U' y y = "
  with gf_U'_tendsto_U'[of y y] ‹recurrent y
  have "LIM z (at_left 1). gf_U' y y z :> at_top"
    by (auto simp: ennreal_tendsto_top_eq_at_top U'_def)
  then have "LIM z (at_left 1). gf_U' y y z :> at_infinity"
    by (rule filterlim_mono) (auto simp: at_top_le_at_infinity)
  with inf show ?thesis
    by (auto intro!: tendsto_divide_0)
next
  assume fin: "U' y y  "
  then obtain r where r: "U' y y = ennreal r" and [simp]: "0  r"
    by (cases "U' y y") (auto simp: U'_def)
  then have eq: "enn2real (1 / U' y y) = - 1 / - r" and "1  r"
    using one_le_integral_t[OF ‹recurrent y]
    by (auto simp add: ennreal_1[symmetric] divide_ennreal simp del: ennreal_1)
  have "((λz. ennreal (gf_U' y y z))  ennreal r) (at_left 1)"
    using gf_U'_tendsto_U'[OF ‹recurrent y, of y] r by simp
  then have gf_U': "(gf_U' y y  r) (at_left (1::real))"
    by (rule tendsto_ennrealD)
       (insert summable_gf_U', auto intro!: eventually_at_left_1 suminf_nonneg simp: gf_U'_def u_nonneg)
  show ?thesis
    using 1  r unfolding eq by (intro tendsto_intros gf_U') simp
qed

lemma gf_G_pos:
  fixes z :: real
  assumes z: "0 < z" "z < 1" and *: "(x, y)  acc"
  shows "0 < gf_G x y z"
  unfolding gf_G_def
proof (subst suminf_pos_iff)
  show "summable (λn. p x y n *R z ^ n)"
    using z by (intro convergence_G convergence_G_less_1) simp
  show pos: "n. 0  p x y n *R z ^ n"
    using z by (auto intro!: mult_nonneg_nonneg p_nonneg)
  show "n. 0 < p x y n *R z ^ n"
  proof (rule ccontr)
    assume "¬ (n. 0 < p x y n *R z ^ n)"
    with pos have "n. p x y n * z ^ n = 0"
      by (intro antisym allI) (simp_all add: not_less)
    with z have "n. p x y n = 0"
      by simp
    with *[THEN accD_pos] show False
      by simp
  qed
qed

lemma pos_recurrentI_communicating:
  assumes y: "pos_recurrent y" and x: "(y, x)  communicating"
  shows "pos_recurrent x"
proof -
  from y x have recurrent: "recurrent y" "recurrent x" and fin: "U' y y  "
    by (auto simp: pos_recurrent_def recurrent_iffI_communicating nn_integral_add)
  have pos: "0 < enn2real (1 / U' y y)"
    using one_le_integral_t[OF ‹recurrent y] fin
    by (auto simp: U'_def enn2real_positive_iff less_top[symmetric] ennreal_zero_less_divide ennreal_divide_eq_top_iff)

  from fin obtain r where r: "U' y y = ennreal r" and [simp]: "0  r"
    by (cases "U' y y") (auto simp: U'_def)

  from x obtain n m where "0 < p x y n" "0 < p y x m"
    by (auto dest!: accD_pos simp: communicating_def)

  let ?L = "at_left (1::real)"
  have le: "eventually (λz. p x y n * p y x m * z^(n + m)  (1 - gf_U y y z) / (1 - gf_U x x z)) ?L"
  proof (rule eventually_at_left_1)
    fix z :: real assume z: "0 < z" "z < 1"
    then have conv: "x. convergence_G x x z"
      by (intro convergence_G_less_1) simp
    have sums: "(λi. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i)) sums ((p x y n * p y x m * z^(n + m)) * gf_G y y z)"
      unfolding gf_G_def
      by (intro sums_mult summable_sums) (auto intro!: conv convergence_G[where 'a=real, simplified])
    have "(i. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i))  (i. p x x (i + (n + m)) * z^(i + (n + m)))"
    proof (intro allI suminf_le sums_summable[OF sums] summable_ignore_initial_segment convergence_G[where 'a=real, simplified] convergence_G_less_1)
      show "norm z < 1" using z by simp
      fix i
      have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i))  p x y (n + i) * p y x ((n + i + m) - (n + i))"
        by (intro mult_right_mono prob_reachable_le) simp_all
      also have "  p x x (n + i + m)"
         by (intro prob_reachable_le) simp_all
      finally show "p x y n * p y x m * z ^ (n + m) * (p y y i * z ^ i)  p x x (i + (n + m)) * z ^ (i + (n + m))"
        using z by (auto simp add: ac_simps power_add intro!: mult_left_mono)
    qed
    also have "  gf_G x x z"
      unfolding gf_G_def
      using z
      apply (subst (2) suminf_split_initial_segment[where k="n + m"])
      apply (intro convergence_G conv)
      apply (simp add: sum_nonneg)
      done
    finally have "(p x y n * p y x m * z^(n + m)) * gf_G y y z  gf_G x x z"
      using sums_unique[OF sums] by simp
    then have "(p x y n * p y x m * z^(n + m))  gf_G x x z / gf_G y y z"
      using z gf_G_pos[of z y y] by (simp add: field_simps)
    also have " = (1 - gf_U y y z) / (1 - gf_U x x z)"
      unfolding gf_G_eq_gf_U[OF conv] using gf_G_eq_gf_U(2)[OF conv] by (simp add: field_simps )
    finally show "p x y n * p y x m * z^(n + m)  (1 - gf_U y y z) / (1 - gf_U x x z)" .
  qed

  have "U' x x  "
  proof
    assume "U' x x = "
    have "((λz. (1 - gf_U y y z) / (1 - gf_U x x z))  0) ?L"
    proof (rule lhopital_left)
      show "((λz. 1 - gf_U y y z)  0) ?L"
        using gf_U[of y] recurrent_iff_U_eq_1[of y] ‹recurrent y by (auto intro!: tendsto_eq_intros)
      show "((λz. 1 - gf_U x x z)  0) ?L"
        using gf_U[of x] recurrent_iff_U_eq_1[of x] ‹recurrent x by (auto intro!: tendsto_eq_intros)
      show "eventually (λz. 1 - gf_U x x z  0) ?L"
        by (auto intro!: eventually_at_left_1 simp: gf_G_eq_gf_U(2) convergence_G_less_1)
      show "eventually (λz. - gf_U' x x z  0) ?L"
        using gf_U'_pos[of _ x x] recurrent_iff_U_eq_1[of x] ‹recurrent x
        by (auto intro!: eventually_at_left_1) (metis less_le)
      show "eventually (λz. DERIV (λxa. 1 - gf_U x x xa) z :> - gf_U' x x z) ?L"
        by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
      show "eventually (λz. DERIV (λxa. 1 - gf_U y y xa) z :> - gf_U' y y z) ?L"
        by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)

      have "(gf_U' y y  U' y y) ?L"
        using ‹recurrent y by (rule gf_U'_tendsto_U') simp
      then have *: "(gf_U' y y  r) ?L"
        by (auto simp add: r eventually_at_left_1 dest!: tendsto_ennrealD)
      moreover
      have "(gf_U' x x  U' x x) ?L"
        using ‹recurrent x by (rule gf_U'_tendsto_U') simp
      then have "LIM z ?L. - gf_U' x x z :> at_bot"
        by (simp add: ennreal_tendsto_top_eq_at_top ‹U' x x =  filterlim_uminus_at_top
                 del: ennreal_of_enat_eSuc)
      then have "LIM z ?L. - gf_U' x x z :> at_infinity"
        by (rule filterlim_mono) (auto simp: at_bot_le_at_infinity)
      ultimately show "((λz. - gf_U' y y z / - gf_U' x x z)  0) ?L"
        by (intro tendsto_divide_0[where c="- r"] tendsto_intros)
    qed
    moreover
    have "((λz. p x y n * p y x m * z^(n + m))  p x y n * p y x m) ?L"
      by (auto intro!: tendsto_eq_intros)
    ultimately have "p x y n * p y x m  0"
      using le by (rule tendsto_le[OF trivial_limit_at_left_real])
    with 0 < p x y n 0 < p y x m show False
      by (auto simp add: mult_le_0_iff)
  qed
  with ‹recurrent x show ?thesis
    by (simp add: pos_recurrent_def nn_integral_add)
qed

lemma pos_recurrent_iffI_communicating:
  "(y, x)  communicating  pos_recurrent y  pos_recurrent x"
  using pos_recurrentI_communicating[of x y] pos_recurrentI_communicating[of y x]
  by (auto simp add: communicating_def)

lemma U_le_F: "U x y  F x y"
  by (auto simp: U_def F_def intro!: T.finite_measure_mono)

lemma not_empty_irreducible: "C  UNIV // communicating  C  {}"
  by (auto simp: quotient_def Image_def communicating_def)

subsection ‹Stationary distribution›

definition stat :: "'s set  's measure" where
  "stat C = point_measure UNIV (λx. indicator C x / U' x x)"

lemma sets_stat[simp]: "sets (stat C) = sets (count_space UNIV)"
  by (simp add: stat_def sets_point_measure)

lemma space_stat[simp]: "space (stat C) = UNIV"
  by (simp add: stat_def space_point_measure)

lemma stat_subprob:
  assumes C: "essential_class C" and "countable C" and pos: "cC. pos_recurrent c"
  shows "emeasure (stat C) C  1"
proof -
  let ?L = "at_left (1::real)"
  from finite_sequence_to_countable_set[OF ‹countable C] guess A . note A = this
  then have "(λn. emeasure (stat C) (A n))  emeasure (stat C) (i. A i)"
    by (intro Lim_emeasure_incseq) (auto simp: incseq_Suc_iff)
  then have "emeasure (stat C) (i. A i)  1"
  proof (rule LIMSEQ_le[OF _ tendsto_const], intro exI allI impI)
    fix n
    from A(1,3) have A_n: "finite (A n)"
      by auto

    from C have "C  {}"
      by (simp add: essential_class_def not_empty_irreducible)
    then obtain x where "x  C" by auto

    have "((λz. (yA n. gf_F x y z * ((1 - z) / (1 - gf_U y y z))))  (yA n. F x y * enn2real (1 / U' y y))) ?L"
    proof (intro tendsto_intros gf_F, rule lhopital_left)
      fix y assume "y  A n"
      with A n  C have "y  C"
        by auto
      show "((-) 1  0) ?L"
        by (intro tendsto_eq_intros) simp_all
      have "recurrent y"
        using pos[THEN bspec, OF yC] by (simp add: pos_recurrent_def)
      then have "U y y = 1"
        by (simp add: recurrent_iff_U_eq_1)

      show "((λx. 1 - gf_U y y x)  0) ?L"
        using gf_U[of y y] ‹U y y = 1 by (intro tendsto_eq_intros) auto
      show "eventually (λx. 1 - gf_U y y x  0) ?L"
        using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
      have "eventually (λx. 0 < gf_U' y y x) ?L"
        by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: ‹U y y = 1)
      then show "eventually (λx. - gf_U' y y x  0) ?L"
        by eventually_elim simp
      show "eventually (λx. DERIV (λx. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
        by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
      show "eventually (λx. DERIV ((-) 1) x :> - 1) ?L"
        by (auto intro!: eventually_at_left_1 derivative_eq_intros)
      show "((λx. - 1 / - gf_U' y y x)  enn2real (1 / U' y y)) ?L"
        using ‹recurrent y by (rule inverse_gf_U'_tendsto)
    qed
    also have "(yA n. F x y * enn2real (1 / U' y y)) = (yA n. enn2real (1 / U' y y))"
    proof (intro sum.cong refl)
      fix y assume "y  A n"
      with A n  C have "y  C" by auto
      with x  C have "(x, y)  communicating"
        by (rule essential_classD3[OF C])
      with yC have "recurrent y" "(y, x)  acc"
        using pos[THEN bspec, of y] by (auto simp add: pos_recurrent_def communicating_def)
      then have "U x y = 1"
        by (rule recurrent_acc)
      with F_le_1[of x y] U_le_F[of x y] have "F x y = 1" by simp
      then show "F x y * enn2real (1 / U' y y) = enn2real (1 / U' y y)"
        by simp
    qed
    finally have le: "(yA n. enn2real (1 / U' y y))  1"
    proof (rule tendsto_le[OF trivial_limit_at_left_real tendsto_const], intro eventually_at_left_1)
      fix z :: real assume z: "0 < z" "z < 1"
      with x  C have "norm z < 1"
        by auto
      then have conv: "x y. convergence_G x y z"
        by (simp add: convergence_G_less_1)
      have "(yA n. gf_F x y z / (1 - gf_U y y z)) = (yA n. gf_G x y z)"
        using ‹norm z < 1
        apply (intro sum.cong refl)
        apply (subst gf_G_eq_gf_F)
        apply assumption
        apply (subst gf_G_eq_gf_U(1)[OF conv])
        apply auto
        done
      also have " = (yA n. n. p x y n * z^n)"
        by (simp add: gf_G_def)
      also have "  = (i. yA n. p x y i *R z^i)"
        by (subst suminf_sum[OF convergence_G[OF conv]]) simp
      also have "   (i. z^i)"
      proof (intro suminf_le summable_sum convergence_G conv summable_geometric allI)
        fix l
        have "(yA n. p x y l *R z ^ l) = (yA n. p x y l) * z ^ l"
          by (simp add: sum_distrib_right)
        also have "  z ^ l"
        proof (intro mult_left_le_one_le)
          have "(yA n. p x y l) = 𝒫(ω in T x. (x ## ω) !! l  A n)"
            unfolding p_def using ‹finite (A n)
            by (subst T.finite_measure_finite_Union[symmetric])
               (auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure])
          then show "(yA n. p x y l)  1"
            by simp
        qed (insert z, auto simp: sum_nonneg)
        finally show "(yA n. p x y l *R z ^ l)  z ^ l" .
      qed fact
      also have " = 1 / (1 - z)"
        using sums_unique[OF geometric_sums, OF ‹norm z < 1] ..
      finally have "(yA n. gf_F x y z / (1 - gf_U y y z))  1 / (1 - z)" .
      then have "(yA n. gf_F x y z / (1 - gf_U y y z)) * (1 - z)  1"
        using z by (simp add: field_simps)
      then have "(yA n. gf_F x y z / (1 - gf_U y y z) * (1 - z))  1"
        by (simp add: sum_distrib_right)
      then show "(yA n. gf_F x y z * ((1 - z) / (1 - gf_U y y z)))  1"
        by simp
    qed

    from A_n have "emeasure (stat C) (A n) = (yA n. emeasure (stat C) {y})"
      by (intro emeasure_eq_sum_singleton) simp_all
    also have " = (yA n. inverse (U' y y))"
      unfolding stat_def U'_def using A(1)[of n]
      apply (intro sum.cong refl)
      apply (subst emeasure_point_measure_finite2)
        apply (auto simp: divide_ennreal_def Collect_conv_if)
      done
    also have " = ennreal (yA n. enn2real (1 / U' y y))"
      apply (subst sum_ennreal[symmetric], simp)
    proof (intro sum.cong refl)
      fix y assume "y  A n"
      with A n  C pos have "pos_recurrent y"
        by auto
      with one_le_integral_t[of y] obtain r where "U' y y = ennreal r" "1  U' y y" and [simp]: "0  r"
        by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)
      then show "inverse (U' y y) = ennreal (enn2real (1 / U' y y))"
        by (simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide del: ennreal_1)
    qed
    also have "  1"
      using le by simp
    finally show "emeasure (stat C) (A n)  1" .
  qed
  with A show ?thesis
    by simp
qed

lemma emeasure_stat_not_C:
  assumes "y  C"
  shows "emeasure (stat C) {y} = 0"
  unfolding stat_def using y  C
  by (subst emeasure_point_measure_finite2) auto

definition stationary_distribution :: "'s pmf  bool" where
  "stationary_distribution N  N = bind_pmf N K"

lemma stationary_distributionI:
  assumes le: "y. (x. pmf (K x) y measure_pmf N)  pmf N y"
  shows "stationary_distribution N"
  unfolding stationary_distribution_def
proof (rule pmf_eqI antisym)+
  fix i
  show "pmf (bind_pmf N K) i  pmf N i"
    by (simp add: pmf_bind le)

  define Ω where "Ω = N  (iN. set_pmf (K i))"
  then have Ω: "countable Ω"
    by (auto intro: countable_set_pmf)
  then interpret N: sigma_finite_measure "count_space Ω"
    by (rule sigma_finite_measure_count_space_countable)
  interpret pN: pair_sigma_finite N "count_space Ω"
    by unfold_locales

  have measurable_pmf[measurable]: "(λ(x, y). pmf (K x) y)  borel_measurable (N M count_space Ω)"
    unfolding measurable_split_conv
    apply (rule measurable_compose_countable'[OF _ measurable_snd])
    apply (rule measurable_compose[OF measurable_fst])
    apply (simp_all add: Ω)
    done

  { assume *: "(y. pmf (K y) i N) < pmf N i"
    have "0  (y. pmf (K y) i N)"
      by (intro integral_nonneg_AE) simp
    with * have i: "i  set_pmf N" "i  Ω"
      by (auto simp: set_pmf_iff Ω_def not_le[symmetric])
    from * have "0 < pmf N i - (y. pmf (K y) i N)"
      by (simp add: field_simps)
    also have " = (t. (pmf N i - (y. pmf (K y) i N)) * indicator {i} t count_space Ω)"
      by (simp add: i)
    also have "  (t. pmf N t - y. pmf (K y) t N count_space Ω)"
      using le
      by (intro integral_mono integrable_diff)
         (auto simp: i pmf_bind[symmetric] integrable_pmf field_simps split: split_indicator)
    also have " = (t. pmf N t count_space Ω) - (t. y. pmf (K y) t N count_space Ω)"
      by (subst Bochner_Integration.integral_diff) (auto intro!: integrable_pmf simp: pmf_bind[symmetric])
    also have "(t. y. pmf (K y) t N count_space Ω) = (y. t. pmf (K y) t count_space Ω N)"
      apply (intro pN.Fubini_integral integrable_iff_bounded[THEN iffD2] conjI)
      apply (auto simp add: N.nn_integral_fst[symmetric] nn_integral_eq_integral integrable_pmf)
      unfolding less_top[symmetric] unfolding infinity_ennreal_def[symmetric]
      apply (intro integrableD)
      apply (auto intro!: measure_pmf.integrable_const_bound[where B=1]
                  simp: AE_measure_pmf_iff integral_nonneg_AE integral_pmf)
      done
    also have "(y. t. pmf (K y) t count_space Ω N) = (y. 1 N)"
      by (intro integral_cong_AE)
         (auto simp: AE_measure_pmf_iff integral_pmf Ω_def intro!: measure_pmf.prob_eq_1[THEN iffD2])
    finally have False
      using measure_pmf.prob_space[of N] by (simp add: integral_pmf field_simps not_le[symmetric]) }
  then show "pmf N i  pmf (bind_pmf N K) i"
    by (auto simp: pmf_bind not_le[symmetric])
qed

lemma stationary_distribution_iterate:
  assumes N: "stationary_distribution N"
  shows "ennreal (pmf N y) = (+x. p x y n N)"
proof (induct n arbitrary: y)
  have [simp]: "x y. ennreal (if x = y then 1 else 0) = indicator {y} x"
    by simp
  case 0 then show ?case
    by (simp add: p_0 pmf.rep_eq measure_pmf.emeasure_eq_measure)
next
  case (Suc n) with N show ?case
    apply (simp add: nn_integral_eq_integral[symmetric] p_le_1 p_Suc'
                     measure_pmf.integrable_const_bound[where B=1])
    apply (subst nn_integral_bind[symmetric, where B="count_space UNIV"])
    apply (auto simp: stationary_distribution_def measure_pmf_bind[symmetric]
                simp del: measurable_pmf_measure1)
    done
qed

lemma stationary_distribution_iterate':
  assumes "stationary_distribution N"
  shows "measure N {y} = (x. p x y n N)"
  using stationary_distribution_iterate[OF assms]
  by (subst (asm) nn_integral_eq_integral)
     (auto intro!: measure_pmf.integrable_const_bound[where B=1] simp: p_le_1 pmf.rep_eq)

lemma stationary_distributionD:
  assumes C: "essential_class C" "countable C"
  assumes N: "stationary_distribution N" "N  C"
  shows "xC. pos_recurrent x" "measure_pmf N = stat C"
proof -
  have integrable_K: "f x. integrable N (λs. pmf (K s) (f x))"
    by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: pmf_le_1)

  have measure_C: "measure N C = 1" and ae_C: "AE x in N. x  C"
    using N C measure_pmf.prob_eq_1[of C] by (auto simp: AE_measure_pmf_iff)

  have integrable_p: "n y. integrable N (λx. p x y n)"
    by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: p_le_1)

  { fix e :: real assume "0 < e"
    then have [simp]: "0  e" by simp
    have "AC. finite A  1 - e < measure N A"
    proof (rule ccontr)
      assume contr: "¬ (A  C. finite A  1 - e < measure N A)"
      from finite_sequence_to_countable_set[OF ‹countable C] guess F . note F = this
      then have *: "(λn. measure N (F n))  measure N (i. F i)"
        by (intro measure_pmf.finite_Lim_measure_incseq) (auto simp: incseq_Suc_iff)
      with F contr have "measure N (i. F i)  1 - e"
        by (intro LIMSEQ_le[OF * tendsto_const]) (auto simp: not_less)
      with F 0 < e show False
        by (simp add: measure_C)
    qed
    then obtain A where "A  C" "finite A" and e: "1 - e < measure N A" by auto

    { fix y n assume "y  C"
      from N(1) have "measure N {y} = (x. p x y n N)"
        by (rule stationary_distribution_iterate')
      also have "  (x. p x y n * indicator A x + indicator (C - A) x N)"
        using ae_C A  C
        by (intro integral_mono_AE)
           (auto elim!: eventually_mono
                 intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
                   integrable_add
                 split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
      also have " = (x. p x y n * indicator A x N) + measure N (C - A)"
        using ae_C A  C
        apply (subst Bochner_Integration.integral_add)
        apply (auto elim!: eventually_mono
                    intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
                    split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
        done
      also have "  (x. p x y n * indicator A x N) + e"
        using e A  C  by (simp add: measure_pmf.finite_measure_Diff measure_C)
      finally have "measure N {y}  (x. p x y n * indicator A x N) + e" .
      then have "emeasure N {y}  ennreal (x. p x y n * indicator A x N) + e"
        by (simp add: measure_pmf.emeasure_eq_measure ennreal_plus[symmetric] del: ennreal_plus)
      also have " = (+x. ennreal (p x y n) * indicator A x N) + e"
        by (subst nn_integral_eq_integral[symmetric])
           (auto intro!: measure_pmf.integrable_const_bound[where B=1]
                 simp: abs_mult p_le_1 mult_le_one ennreal_indicator ennreal_mult)
      finally have "emeasure N {y}  (+x. ennreal (p x y n) * indicator A x N) + e" . }
    note v_le = this

    { fix y and z :: real assume y: "y  C" and z: "0 < z" "z < 1"
      have summable_int_p: "summable (λn. ( x. p x y n * indicator A x N) * (1 - z) * z ^ n)"
        using yC z A  C
        by (auto intro!: summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] exI[of _ 0] mult_le_one
                            measure_pmf.integral_le_const integrable_real_mult_indicator integrable_p AE_I2 p_le_1
                    simp: abs_mult integral_nonneg_AE)

      from y z have sums_y: "(λn. measure N {y} * (1 - z) * z ^ n) sums measure N {y}"
        using sums_mult[OF geometric_sums[of z], of "measure N {y} * (1 - z)"] by simp
      then have "emeasure N {y} = ennreal (n. (measure N {y} * (1 - z)) * z ^ n)"
        by (auto simp add: sums_unique[symmetric] measure_pmf.emeasure_eq_measure)
      also have " = (n. emeasure N {y} * (1 - z) * z ^ n)"
        using z  summable_mult[OF summable_geometric[of z], of "measure_pmf.prob N {y} * (1 - z)"]
        by (subst suminf_ennreal[symmetric])
           (auto simp: measure_pmf.emeasure_eq_measure ennreal_mult[symmetric] ennreal_suminf_neq_top)
      also have "  (n. ((+x. ennreal (p x y n) * indicator A x N) + e) * (1 - z) * z ^ n)"
        using yC z A  C
        by (intro suminf_le mult_right_mono v_le allI)
           (auto simp: measure_pmf.emeasure_eq_measure)
      also have " = (n. (+x. ennreal (p x y n) * indicator A x N) * (1 - z) * z ^ n) + e"
        using 0 < e z sums_mult[OF geometric_sums[of z], of "e * (1 - z)"] 0<z z<1
        by (simp add: distrib_right suminf_add[symmetric] ennreal_suminf_cmult[symmetric]
                      ennreal_mult[symmetric] suminf_ennreal_eq sums_unique[symmetric]
                 del: ennreal_suminf_cmult)
      also have " = (n. ennreal (1 - z) * ((+x. ennreal (p x y n) * indicator A x N) * z ^ n)) + e"
        by (simp add: ac_simps)
      also have " = ennreal (1 - z) * (n. ((+x. ennreal (p x y n) * indicator A x N) * z ^ n)) + e"
        using z by (subst ennreal_suminf_cmult) simp_all
      also have "(n. ((+x. ennreal (p x y n) * indicator A x N) * z ^ n)) =
          (n. (+x. ennreal (p x y n * z ^ n) * indicator A x N))"
        using z by (simp add: ac_simps nn_integral_cmult[symmetric] ennreal_mult)
      also have " = (+x. ennreal (gf_G x y z) * indicator A x N)"
        using z
        apply (subst nn_integral_suminf[symmetric])
        apply (auto simp add: gf_G_def simp del: suminf_ennreal
                    intro!: ennreal_mult_right_cong suminf_ennreal2 nn_integral_cong)
        apply (intro summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] impI)
        apply (simp_all add: abs_mult p_le_1 mult_le_one power_le_one split: split_indicator)
        done
      also have " = (+x. ennreal (gf_F x y z * gf_G y y z) * indicator A x N)"
        using z by (intro nn_integral_cong) (simp add: gf_G_eq_gf_F[symmetric])
      also have " = ennreal (gf_G y y z) * (+x. ennreal (gf_F x y z) * indicator A x N)"
        using z by (subst nn_integral_cmult[symmetric]) (simp_all add: gf_G_nonneg gf_F_nonneg ac_simps ennreal_mult)
      also have " = ennreal (1 / (1 - gf_U y y z)) * (+x. ennreal (gf_F x y z) * indicator A x N)"
        using z y  C by (subst gf_G_eq_gf_U) (auto intro!: convergence_G_less_1)
      finally have "emeasure N {y}  ennreal ((1 - z) / (1 - gf_U y y z)) * (+x. gf_F x y z * indicator A x N) + e"
        using z
        by (subst (asm) mult.assoc[symmetric])
           (simp add: ennreal_indicator[symmetric] ennreal_mult'[symmetric] gf_F_nonneg)
      then have "measure N {y}  (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e"
        using z
        by (subst (asm) nn_integral_eq_integral[OF measure_pmf.integrable_const_bound[where B=1]])
           (auto simp: gf_F_nonneg gf_U_le_1 gf_F_le_1 measure_pmf.emeasure_eq_measure mult_le_one
                       ennreal_mult''[symmetric] ennreal_plus[symmetric]
                 simp del: ennreal_plus) }
    then have "A  C. finite A  (yC. z. 0 < z  z < 1  measure N {y}  (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e)"
      using A  C ‹finite A by auto }
  note eps = this

  { fix y A assume "y  C" "finite A" "A  C"
    then have "((λz. x. gf_F x y z * indicator A x N)  x. F x y * indicator A x N) (at_left 1)"
      by (subst (1 2) integral_measure_pmf[of A]) (auto intro!: tendsto_intros gf_F simp: indicator_eq_0_iff) }
  note int_gf_F = this

  have all_recurrent: "yC. recurrent y"
  proof (rule ccontr)
    assume "¬ (yC. recurrent y)"
    then obtain x where "x  C" "¬ recurrent x" by auto
    then have transient: "x. x  C  ¬ recurrent x"
      using C by (auto simp: essential_class_def recurrent_iffI_communicating[symmetric] elim!: quotientE)

    { fix y assume "y  C"
      with transient have "U y y < 1"
        by (metis recurrent_iff_U_eq_1 U_cases)
      have "measure N {y}  0"
      proof (rule dense_ge)
        fix e :: real assume "0 < e"
        from eps[OF this] y  C obtain A where
          A: "finite A" "A  C" and
          le: "z. 0 < z  z < 1  measure N {y}  (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e"
          by auto
        have "((λz. (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e) 
          (1 - 1) / (1 - U y y) * (x. F x y * indicator A x N) + e) (at_left (1::real))"
          using A ‹U y y < 1 y  C by (intro tendsto_intros gf_U int_gf_F) auto
        then have 1: "((λz. (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e)  e) (at_left (1::real))"
          by simp
        with le show "measure N {y}  e"
          by (intro tendsto_le[OF trivial_limit_at_left_real _ tendsto_const])
             (auto simp: eventually_at_left_1)
      qed
      then have "measure N {y} = 0"
        by (intro antisym measure_nonneg) }
    then have "emeasure N C = 0"
      by (subst emeasure_countable_singleton) (auto simp: measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE ae_C C)
    then show False
      using ‹measure N C = 1 by (simp add: measure_pmf.emeasure_eq_measure)
  qed
  then have "x. x  C  U x x = 1"
    by (metis recurrent_iff_U_eq_1)

  { fix y assume "y  C"
    then have "U y y = 1" "recurrent y"
      using y  C  U y y = 1 all_recurrent by auto
    have "measure N {y}  enn2real (1 / U' y y)"
    proof (rule field_le_epsilon)
      fix e :: real assume "0 < e"
      from eps[OF 0 < e] y  C obtain A where
        A: "finite A" "A  C" and
        le: "z. 0 < z  z < 1  measure N {y}  (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e"
        by auto
      let ?L = "at_left (1::real)"
      have "((λz. (1 - z) / (1 - gf_U y y z) * (x. gf_F x y z * indicator A x N) + e) 
          enn2real (1 / U' y y) * (x. F x y * indicator A x N) + e) ?L"
      proof (intro tendsto_add tendsto_const tendsto_mult int_gf_F,
             rule lhopital_left[where f'="λx. - 1" and g'="λz. - gf_U' y y z"])
        show "((-) 1  0) ?L" "((λx. 1 - gf_U y y x)  0) ?L"
          using gf_U[of y y] by (auto intro!: tendsto_eq_intros simp: ‹U y y = 1)
        show "y  C" "finite A" "A  C" by fact+
        show "eventually (λx. 1 - gf_U y y x  0) ?L"
          using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
        show "((λx. - 1 / - gf_U' y y x)  enn2real (1 / U' y y)) ?L"
          using ‹recurrent y by (rule inverse_gf_U'_tendsto)
        have "eventually (λx. 0 < gf_U' y y x) ?L"
          by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: ‹U y y = 1)
        then show "eventually (λx. - gf_U' y y x  0) ?L"
          by eventually_elim simp
        show "eventually (λx. DERIV (λx. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
          by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
        show "eventually (λx. DERIV ((-) 1) x :> - 1) ?L"
          by (auto intro!: eventually_at_left_1 derivative_eq_intros)
      qed
      then have "measure N {y}  enn2real (1 / U' y y) * (x. F x y * indicator A x N) + e"
        by (rule tendsto_le[OF trivial_limit_at_left_real _ tendsto_const]) (intro eventually_at_left_1 le)
      then have "measure N {y} - e  enn2real (1 / U' y y) * (x. F x y * indicator A x N)"
        by simp
      also have "  enn2real (1 / U' y y)"
        using A
        by (intro mult_left_le measure_pmf.integral_le_const measure_pmf.integrable_const_bound[where B=1])
           (auto simp: mult_le_one F_le_1 U'_def)
      finally show "measure N {y}  enn2real (1 / U' y y) + e"
        by simp
    qed }
  note measure_y_le = this

  show pos: "yC. pos_recurrent y"
  proof (rule ccontr)
    assume "¬ (yC. pos_recurrent y)"
    then obtain x where x: "x  C" "¬ pos_recurrent x" by auto
    { fix y assume "y  C"
      with x have "¬ pos_recurrent y"
        using C by (auto simp: essential_class_def pos_recurrent_iffI_communicating[symmetric] elim!: quotientE)
      with all_recurrent y  C have "enn2real (1 / U' y y) = 0"
        by (simp add: pos_recurrent_def nn_integral_add)
      with measure_y_le[OF y  C] have "measure N {y} = 0"
        by (auto intro!: antisym simp: pos_recurrent_def) }
    then have "emeasure N C = 0"
      by (subst emeasure_countable_singleton) (auto simp: C ae_C measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE)
    then show False
      using ‹measure N C = 1 by (simp add: measure_pmf.emeasure_eq_measure)
  qed

  { fix A :: "'s set" assume [simp]: "countable A"
    have "emeasure N A = (+x. emeasure N {x} count_space A)"
      by (intro emeasure_countable_singleton) auto
    also have "  (+x. emeasure (stat C) {x} count_space A)"
    proof (intro nn_integral_mono)
      fix y assume "y  space (count_space A)"
      show "emeasure N {y}  emeasure (stat C) {y}"
      proof cases
        assume "y  C"
        with pos have "pos_recurrent y"
          by auto
        with one_le_integral_t[of y] obtain r where r: "U' y y = ennreal r" "1  U' y y" and [simp]: "0  r"
          by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)

        from measure_y_le[OF y  C]
        have "emeasure N {y}  ennreal (enn2real (1 / U' y y))"
          by (simp add: measure_pmf.emeasure_eq_measure)
        also have " = emeasure (stat C) {y}"
          unfolding stat_def using y  C r
          by (subst emeasure_point_measure_finite2)
             (auto simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide ennreal_mult[symmetric]
                   simp del: ennreal_1)
        finally show "emeasure N {y}  emeasure (stat C) {y}"
          by simp
      next
        assume "y  C"
        with ae_C have "emeasure N {y} = 0"
          by (subst AE_iff_measurable[symmetric, where P="λx. x  y"]) (auto elim!: eventually_mono)
        moreover have "emeasure (stat C) {y} = 0"
          using emeasure_stat_not_C[OF y  C] .
        ultimately show ?thesis by simp
      qed
    qed
    also have " = emeasure (stat C) A"
      by (intro emeasure_countable_singleton[symmetric]) auto
    finally have "emeasure N A  emeasure (stat C) A" . }
  note N_le_C = this

  from stat_subprob[OF C(1) ‹countable C pos] N_le_C[OF ‹countable C] ‹measure N C = 1
  have stat_C_eq_1: "emeasure (stat C) C = 1"
    by (auto simp add: measure_pmf.emeasure_eq_measure one_ennreal_def)
  moreover have "emeasure (stat C) (UNIV - C) = 0"
    by (subst AE_iff_measurable[symmetric, where P="λx. x  C"])
       (auto simp: stat_def AE_point_measure sets_point_measure space_point_measure
                split: split_indicator cong del: AE_cong)
  ultimately have "emeasure (stat C) (space (stat C)) = 1"
    using plus_emeasure[of C "stat C" "UNIV - C"] by (simp add: Un_absorb1)
  interpret stat: prob_space "stat C"
    by standard fact

  show "measure_pmf N = stat C"
  proof (rule measure_eqI_countable_AE)
    show "sets N = UNIV" "sets (stat C) = UNIV"
      by auto
    show "countable C" "AE x in N. x  C" and ae_stat: "AE x in stat C. x  C"
      using C ae_C stat_C_eq_1 by (auto intro!: stat.AE_prob_1 simp: stat.emeasure_eq_measure)

    { assume "x. emeasure N {x}  emeasure (stat C) {x}"
      then obtain x where [simp]: "emeasure N {x}  emeasure (stat C) {x}" by auto
      with N_le_C[of "{x}"] have x: "emeasure N {x} < emeasure (stat C) {x}"
        by (auto simp: less_le)
      have "1 = emeasure N {x} + emeasure N (C - {x})"
        using ae_C
        by (subst plus_emeasure) (auto intro!: measure_pmf.emeasure_eq_1_AE)
      also have " < emeasure (stat C) {x} + emeasure (stat C) (C - {x})"
        using x N_le_C[of "C - {x}"] C ae_C
        by (simp add: stat.emeasure_eq_measure measure_pmf.emeasure_eq_measure
                      ennreal_plus[symmetric] ennreal_less_iff
                 del: ennreal_plus)
      also have " = 1"
        using ae_stat by (subst plus_emeasure) (auto intro!: stat.emeasure_eq_1_AE)
      finally have False by simp }
    then show "x. emeasure N {x} = emeasure (stat C) {x}" by auto
  qed
qed

lemma measure_point_measure_singleton:
  "x  A  measure (point_measure A X) {x} = enn2real (X x)"
  unfolding measure_def by (subst emeasure_point_measure_finite2) auto

lemma stationary_distribution_imp_int_t:
  assumes C: "essential_class C" "countable C" "stationary_distribution N" "N  C"
  assumes x: "x  C" shows "U' x x = 1 / ennreal (pmf N x)"
proof -
  from stationary_distributionD[OF C]
  have "measure_pmf N = stat C" and *: "xC. pos_recurrent x" by auto
  show ?thesis
    unfolding ‹measure_pmf N = stat C pmf.rep_eq stat_def
    using *[THEN bspec, OF x] x
    apply (simp add: measure_point_measure_singleton)
    apply (cases "U' x x")
    subgoal for r
      by (cases "r = 0")
         (simp_all add: divide_ennreal_def inverse_ennreal)
    apply simp
    done
qed

definition "period_set x = {i. 0 < i  0 < p x x i }"
definition "period C = (SOME d. xC. d = Gcd (period_set x))"

lemma Gcd_period_set_invariant:
  assumes c: "(x, y)  communicating"
  shows "Gcd (period_set x) = Gcd (period_set y)"
proof -
  { fix x y n assume c: "(x, y)  communicating" "x  y" and n: "n  period_set x"
    from c obtain l k where "0 < p x y l" "0 < p y x k"
      by (auto simp: communicating_def dest!: accD_pos)
    moreover with x  y have "l  0  k  0"
      by (intro notI conjI) (auto simp: p_0)
    ultimately have pos: "0 < l" "0 < k" and l: "0 < p x y l" and k: "0 < p y x k"
      by auto

    from mult_pos_pos[OF k l] prob_reachable_le[of k "k + l" y x y] c
    have k_l: "0 < p y y (k + l)"
      by simp
    then have "Gcd (period_set y) dvd k + l"
      using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def)
    moreover
    from n have "0 < p x x n" "0 < n" by (auto simp: period_set_def)
    from mult_pos_pos[OF k this(1)] prob_reachable_le[of k "k + n" y x x] c
    have "0 < p y x (k + n)"
      by simp
    from mult_pos_pos[OF this(1) l] prob_reachable_le[of "k + n" "(k + n) + l" y x y] c
    have "0 < p y y (k + n + l)"
      by simp
    then have "Gcd (period_set y) dvd (k + l) + n"
      using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def ac_simps)
    ultimately have "Gcd (period_set y) dvd n"
      by (metis dvd_add_left_iff add.commute) }
  note this[of x y] this[of y x] c
  moreover have "(y, x)  communicating"
    using c by (simp add: communicating_def)
  ultimately show ?thesis
    by (auto intro: dvd_antisym Gcd_greatest Gcd_dvd)
qed

lemma period_eq:
  assumes "C  UNIV // communicating" "x  C"
  shows "period C = Gcd (period_set x)"
  unfolding period_def
  using assms
  by (rule_tac someI2[where a="Gcd (period_set x)"])
     (auto intro!: Gcd_period_set_invariant irreducibleD)

definition "aperiodic C  C  UNIV // communicating  period C = 1"

definition "not_ephemeral C  C  UNIV // communicating  ¬ (x. C = {x}  p x x 1 = 0)"

lemma not_ephemeralD:
  assumes C: "not_ephemeral C" "x  C"
  shows "n>0. 0 < p x x n"
proof cases
  assume "x. C = {x}"
  with x  C have "C = {x}" by auto
  with C p_nonneg[of x x 1] have "0 < p x x 1"
    by (auto simp: not_ephemeral_def less_le)
  with C = {x} show ?thesis by auto
next
  from C have irr: "C  UNIV // communicating"
    by (auto simp: not_ephemeral_def)
  assume "¬(x. C = {x})"
  then have "x. C  {x}" by auto
  with x  C obtain y where "y  C" "x  y"
    by blast
  with irreducibleD[OF irr, of x y] C x  C have c: "(x, y)  communicating" by auto
  with accD_pos[of x y] accD_pos[of y x]
  obtain k l where pos: "0 < p x y k" "0 < p y x l"
    by (auto simp: communicating_def)
  with x  y have "l  0"
    by (intro notI) (auto simp: p_0)
  have "0 < p x y k * p y x (k + l - k)"
    using pos by auto
  also have "p x y k * p y x (k + l - k)  p x x (k + l)"
    using prob_reachable_le[of "k" "k + l" x y x] c by auto
  finally show ?thesis
    using l  0 x  C by (auto intro!: exI[of _ "k + l"])
qed

lemma not_ephemeralD_pos_period:
  assumes C: "not_ephemeral C"
  shows "0 < period C"
proof -
  from C not_empty_irreducible[of C] obtain x where "x  C"
    by (auto simp: not_ephemeral_def)
  from not_ephemeralD[OF C this]
  obtain n where n: "0 < p x x n" "0 < n" by auto
  have C': "C  UNIV // communicating"
    using C by (auto simp: not_ephemeral_def)

  have "period C  0"
    unfolding period_eq [OF C' x  C]
    using n by (auto simp: period_set_def)
  then show ?thesis by auto
qed


lemma period_posD:
  assumes C: "C  UNIV // communicating" and "0 < period C" "x  C"
  shows "n>0. 0 < p x x n"
proof -
  from 0 < period C have "period C  0"
    by auto
  then show ?thesis
    unfolding period_eq [OF C x  C]
    unfolding period_set_def by auto
qed

lemma not_ephemeralD_pos_period':
  assumes C: "C  UNIV // communicating"
  shows "not_ephemeral C  0 < period C"
proof (auto dest!: not_ephemeralD_pos_period intro: C)
  from C not_empty_irreducible[of C] obtain x where "x  C"
    by (auto simp: not_ephemeral_def)

  assume "0 < period C"
  then show "not_ephemeral C"
    apply (auto simp: not_ephemeral_def C)
oops ― ‹should be easy to finish›


lemma eventually_periodic:
  assumes C: "C  UNIV // communicating" "0 < period C" "x  C"
  shows "eventually (λm. 0 < p x x (m * period C)) sequentially"
proof -
  from period_posD[OF assms] obtain n where n: "0 < p x x n" "0 < n" by auto
  have C': "C  UNIV // communicating"
    using C by auto

  have "period C  0"
    unfolding period_eq [OF C' x  C]
    using n by (auto simp: period_set_def)
  have "eventually (λm. m * Gcd (period_set x)  (period_set x)) sequentially"
  proof (rule eventually_mult_Gcd)
    show "n > 0" "n  period_set x"
      using n by (auto simp add: period_set_def)
    fix k l  assume "k  period_set x" "l  period_set x"
    then have "0 < p x x k * p x x l" "0 < l" "0 < k"
      by (auto simp: period_set_def)
    moreover have "p x x k * p x x l  p x x (k + l)"
      using prob_reachable_le[of k "k + l" x x x] x  C
      by auto
    ultimately show "k + l  period_set x"
      using 0 < l by (auto simp: period_set_def)
  qed
  with eventually_ge_at_top[of 1] show "eventually (λm. 0 < p x x (m * period C)) sequentially"
    by eventually_elim 
       (insert ‹period C  0 period_eq[OF C' x  C, symmetric], auto simp: period_set_def)
qed


lemma aperiodic_eventually_recurrent:
  "aperiodic C  C  UNIV // communicating  (xC. eventually (λm. 0 < p x x m) sequentially)"
proof safe
  fix x assume "x  C" "aperiodic C"
  with eventually_periodic[of C x]
  show "eventually (λm. 0 < p x x m) sequentially"
    by (auto simp add: aperiodic_def)
next
  assume "xC. eventually (λm. 0 < p x x m) sequentially" and C: "C  UNIV // communicating"
  moreover from not_empty_irreducible[OF C] obtain x where "x  C" by auto
  ultimately obtain N where "M.  MN  0 < p x x M"
    by (auto simp: eventually_sequentially)
  then have "{N <..}  period_set x"
    by (auto simp: period_set_def)
  from C show "aperiodic C"
    unfolding period_eq [OF C x  C] aperiodic_def
  proof
    show "Gcd (period_set x) = 1"
    proof (rule Gcd_eqI)
      from one_dvd show "1 dvd q" for q :: nat .
      fix m
      assume "q. q  period_set x  m dvd q"
      moreover from {N <..}  period_set x
      have "{Suc N, Suc (Suc N)}  period_set x"
        by auto
      ultimately have "m dvd Suc (Suc N)" and "m dvd Suc N"
        by auto
      then have "m dvd Suc (Suc N) - Suc N"
        by (rule dvd_diff_nat)
      then show "is_unit m"
        by simp
    qed simp
  qed
qed (simp add: aperiodic_def)

lemma stationary_distributionD_emeasure:
  assumes N: "stationary_distribution N"
  shows "emeasure N A = (+s. emeasure (K s) A N)"
proof -
  have "prob_space (measure_pmf N)"
    by intro_locales
  then interpret subprob_space "measure_pmf N"
    by (rule prob_space_imp_subprob_space)
  show ?thesis
    unfolding measure_pmf.emeasure_eq_measure
    apply (subst N[unfolded stationary_distribution_def])
    apply (simp add: measure_pmf_bind)
    apply (subst measure_pmf.measure_bind[where N="count_space UNIV"])
    apply (rule measurable_compose[OF _ measurable_measure_pmf])
    apply (auto intro!: nn_integral_eq_integral[symmetric] measure_pmf.integrable_const_bound[where B=1])
    done
qed

lemma communicatingD1:
  "C  UNIV // communicating  (a, b)  communicating  a  C  b  C"
  by (auto elim!: quotientE) (auto simp add: communicating_def)

lemma communicatingD2:
  "C  UNIV // communicating  (a, b)  communicating  b  C  a  C"
  by (auto elim!: quotientE) (auto simp add: communicating_def)

lemma acc_iff: "(x, y)  acc  (n. 0 < p x y n)"
  by (blast intro: accD_pos accI_pos)

lemma communicating_iff: "(x, y)  communicating  (n. 0 < p x y n)  (n. 0 < p y x n)"
  by (auto simp add: acc_iff communicating_def)

end

context MC_pair
begin

lemma p_eq_p1_p2:
  "p (x1, x2) (y1, y2) n = K1.p x1 y1 n * K2.p x2 y2 n"
  unfolding p_def K1.p_def K2.p_def
  by (subst prod_eq_prob_T)
     (auto intro!: arg_cong2[where f=measure] split: nat.splits simp: Stream_snth)

lemma P_accD:
  assumes "((x1, x2), (y1, y2))  acc"shows "(x1, y1)  K1.acc" "(x2, y2)  K2.acc"
  using assms by (auto simp: acc_iff K1.acc_iff K2.acc_iff p_eq_p1_p2 zero_less_mult_iff not_le[of 0, symmetric]
                       cong: conj_cong)

lemma aperiodicI_pair:
  assumes C1: "K1.aperiodic C1" and C2: "K2.aperiodic C2"
  shows "aperiodic (C1 × C2)"
  unfolding aperiodic_eventually_recurrent
proof safe
  from C1[unfolded K1.aperiodic_eventually_recurrent] C2[unfolded K2.aperiodic_eventually_recurrent]
  have C1: "C1  UNIV // K1.communicating" and C2: "C2  UNIV // K2.communicating" and
    ev: "x. x  C1  eventually (λm. 0 < K1.p x x m) sequentially" "x. x  C2  eventually (λm. 0 < K2.p x x m) sequentially"
    by auto
  { fix x1 x2 assume x: "x1  C1" "x2  C2"
    from ev(1)[OF x(1)] ev(2)[OF x(2)]
    show "eventually (λm. 0 < p (x1, x2) (x1, x2) m) sequentially"
       by eventually_elim  (simp add: p_eq_p1_p2 x) }

  { fix x1 x2 y1 y2
    assume acc: "(x1, y1)  K1.acc" "(x2, y2)  K2.acc" "x1  C1" "y1  C1" "x2  C2" "y2  C2"
    then obtain k l where "0 < K1.p x1 y1 l" "0 < K2.p x2 y2 k"
      by (auto dest!: K1.accD_pos K2.accD_pos)
    with acc ev(1)[of y1] ev(2)[of y2]
    have "eventually (λm. 0 < K1.p x1 y1 l * K1.p y1 y1 m  0 < K2.p x2 y2 k * K2.p y2 y2 m) sequentially"
      by (auto elim: eventually_elim2)
    then have "eventually (λm. 0 < K1.p x1 y1 (m + l)  0 < K2.p x2 y2 (m + k)) sequentially"
    proof eventually_elim
      fix m assume "0 < K1.p x1 y1 l * K1.p y1 y1 m  0 < K2.p x2 y2 k * K2.p y2 y2 m"
      with acc
        K1.prob_reachable_le[of l "l + m" x1 y1 y1]
        K2.prob_reachable_le[of k "k + m" x2 y2 y2]
      show "0 < K1.p x1 y1 (m + l)  0 < K2.p x2 y2 (m + k)"
        by (auto simp add: ac_simps)
    qed
    then have "eventually (λm. 0 < K1.p x1 y1 m  0 < K2.p x2 y2 m) sequentially"
      unfolding eventually_conj_iff by (subst (asm) (1 2) eventually_sequentially_seg) (auto elim: eventually_elim2)
    then obtain N where "0 < K1.p x1 y1 N" "0 < K2.p x2 y2 N"
      by (auto simp: eventually_sequentially)
    with acc have "0 < p (x1, x2) (y1, y2) N"
      by (auto simp add: p_eq_p1_p2)
    with acc have "((x1, x2), (y1, y2))  acc"
      by (auto intro!: accI_pos) }
  note 1 = this

  { fix x1 x2 y1 y2 assume acc:"((x1, x2), (y1, y2))  acc"
    moreover from acc obtain k where "0 < p (x1, x2) (y1, y2) k" by (auto dest!: accD_pos)
    ultimately have "(x1, y1)  K1.acc  (x2, y2)  K2.acc"
      by (subst (asm) p_eq_p1_p2)
         (auto intro!: K1.accI_pos K2.accI_pos simp: zero_less_mult_iff not_le[of 0, symmetric]) }
  note 2 = this

  from K1.not_empty_irreducible[OF C1] K2.not_empty_irreducible[OF C2]
  obtain x1 x2 where xC: "x1  C1" "x2  C2" by auto
  show "C1 × C2  UNIV // communicating"
    apply (simp add: quotient_def Image_def)
    apply (safe intro!: exI[of _ x1] exI[of _ x2])
  proof -
    fix y1 y2 assume yC: "y1  C1" "y2  C2"
    from K1.irreducibleD[OF C1 x1  C1 y1  C1] K2.irreducibleD[OF C2 x2  C2 y2  C2]
    show "((x1, x2), (y1, y2))  communicating"
      using 1[of x1 y1 x2 y2] 1[of y1 x1 y2 x2] xC yC
      by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
  next
    fix y1 y2 assume "((x1, x2), (y1, y2))  communicating"
    with 2[of x1 x2 y1 y2] 2[of y1 y2 x1 x2]
    have "(x1, y1)  K1.communicating" "(x2, y2)  K2.communicating"
      by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
    with xC show "y1  C1" "y2  C2"
      using K1.communicatingD1[OF C1] K2.communicatingD1[OF C2] by auto
  qed
qed

lemma stationary_distributionI_pair:
  assumes N1: "K1.stationary_distribution N1"
  assumes N2: "K2.stationary_distribution N2"
  shows "stationary_distribution (pair_pmf N1 N2)"
  unfolding stationary_distribution_def
  unfolding Kp_def pair_pmf_def
  apply (subst N1[unfolded K1.stationary_distribution_def])
  apply (subst N2[unfolded K2.stationary_distribution_def])
  apply (simp add: bind_assoc_pmf bind_return_pmf)
  apply (subst bind_commute_pmf[of N2])
  apply simp
  done

end

context MC_syntax
begin

lemma stationary_distribution_imp_limit:
  assumes C: "aperiodic C" "essential_class C" "countable C" and N: "stationary_distribution N" "N  C"
  assumes [simp]: "y  C"
  shows "(λn. x. ¦p y x n - pmf N x¦ count_space C)  0"
    (is "?L  0")
proof -
  from ‹essential_class C have C_comm: "C  UNIV // communicating"
    by (simp add: essential_class_def)

  define K' where "K' = (λSome x  map_pmf Some (K x) | None  map_pmf Some N)"

  interpret K2: MC_syntax K' .
  interpret KN: MC_pair K K' .

  from stationary_distributionD[OF C(2,3) N]
  have pos: "x. x  C  pos_recurrent x" and "measure_pmf N = stat C" by auto

  have pos: "x. x  C  0 < emeasure N {x}"
    using pos unfolding stat_def ‹measure_pmf N = stat C
    by (subst emeasure_point_measure_finite2)
       (auto simp: U'_def pos_recurrent_def nn_integral_add ennreal_zero_less_divide less_top)
  then have rpos: "x. x  C  0 < pmf N x"
    by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)

  have eq: "x y. (if x = y then 1 else 0) = indicator {y} x" by auto

  have intK: "f x. (x. (f x :: real) K' (Some x)) = (x. f (Some x) K x)"
    by (simp add: K'_def integral_distr map_pmf_rep_eq)

  { fix m and x y :: 's
    have "K2.p (Some x) (Some y) m = p x y m"
      by (induct m arbitrary: x)
         (auto intro!: integral_cong simp add: K2.p_Suc' p_Suc' intK K2.p_0 p_0) }
  note K_p_eq = this

  { fix n and x :: 's have "K2.p (Some x) None n = 0"
      by (induct n arbitrary: x) (auto simp: K2.p_Suc' K2.p_0 intK cong: integral_cong) }
  note K_S_None = this

  from not_empty_irreducible[OF C_comm] obtain c0 where c0: "c0  C" by auto

  have K2_acc: "x y. (Some x, y)  K2.acc  (z. y = Some z  (x, z)  acc)"
    apply (auto simp: K2.acc_iff acc_iff K_p_eq)
    apply (case_tac y)
    apply (auto simp: K_p_eq K_S_None)
    done

  have K2_communicating: "c x. c  C  (Some c, x)  K2.communicating  (c'C. x = Some c')"
  proof safe
    fix x c assume "c  C" "(Some c, x)  K2.communicating"
    then show "c'C. x = Some c'"
      by (cases x)
         (auto simp: communicating_iff K2.communicating_iff K_p_eq K_S_None intro!: irreducibleD2[OF C_comm cC])
  next
    fix c c' x assume "c  C" "c'  C"
    with irreducibleD[OF C_comm this] show "(Some c, Some c')  K2.communicating"
      by (auto simp: K2.communicating_iff communicating_iff K_p_eq)
  qed

  have "Some ` C  UNIV // K2.communicating"
    by (auto simp add: quotient_def Image_def c0 K2_communicating
             intro!: exI[of _ "Some c0"])
  then have "K2.essential_class (Some ` C)"
    by (rule K2.essential_classI)
       (auto simp: K2_acc essential_classD2[OF ‹essential_class C])

  have "K2.aperiodic (Some ` C)"
    unfolding K2.aperiodic_eventually_recurrent
  proof safe
    fix x assume "x  C" then show "eventually (λm. 0 < K2.p (Some x) (Some x) m) sequentially"
      using ‹aperiodic C unfolding aperiodic_eventually_recurrent
      by (auto elim!: eventually_mono simp: K_p_eq)
  qed fact
  then have aperiodic: "KN.aperiodic (C × Some ` C)"
    by (rule KN.aperiodicI_pair[OF ‹aperiodic C])

  have KN_essential: "KN.essential_class (C × Some ` C)"
  proof (rule KN.essential_classI)
    show "C × Some ` C  UNIV // KN.communicating"
      using aperiodic by (simp add: KN.aperiodic_def)
  next
    fix x y assume "x  C × Some ` C" "(x, y)  KN.acc"
    with KN.P_accD[of "fst x" "snd x" "fst y" "snd y"]
    show "y  C × Some ` C"
      by (cases x y rule: prod.exhaust[case_product prod.exhaust])
         (auto simp: K2_acc essential_classD2[OF ‹essential_class C])
  qed

  { fix n and x y :: 's
    have "measure N {y} = 𝒫(ω in K2.T None. (None ## ω) !! (Suc n) = Some y)"
      unfolding stationary_distribution_iterate'[OF N(1), of y n]
      apply (subst K2.p_def[symmetric])
      apply (subst K2.p_Suc')
      apply (subst K'_def)
      apply (simp add: map_pmf_rep_eq integral_distr K_p_eq)
      done
    then have "measure N {y} = 𝒫(ω in K2.T None. ω !! n = Some y)"
      by simp }
  note measure_y_eq = this

  define D where "D = {x::'s × 's option. Some (fst x) = snd x}"

  have [measurable]:
    "P::('s × 's option  bool). P  measurable (count_space UNIV) (count_space UNIV)"
    by simp

  { fix n and x :: 's
    have "𝒫(ω in KN.T (y, None). i<n. snd (ω !! n) = Some x  ev_at (HLD D) i ω) =
      (i<n. 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ev_at (HLD D) i ω))"
      by (subst KN.T.finite_measure_finite_Union[symmetric])
         (auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure] dest: ev_at_unique)
    also have " = (i<n. 𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ev_at (HLD D) i ω))"
    proof (intro sum.cong refl)
      fix i assume i: "i  {..< n}"
      show "𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ev_at (HLD D) i ω) =
        𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ev_at (HLD D) i ω)"
        apply (subst (1 2) KN.prob_T_split[where n="Suc i"])
        apply (simp_all add: ev_at_shift snth_Stream del: stake.simps KN.space_T)
        unfolding ev_at_shift snth_Stream
      proof (intro Bochner_Integration.integral_cong refl)
        fix ω :: "('s × 's option) stream" let ?s = "λω'. stake (Suc i) ω @- ω'"
        show "𝒫(ω' in KN.T (ω !! i). snd (?s ω' !! n) = Some x  ev_at (HLD D) i ω) =
          𝒫(ω' in KN.T (ω !! i). fst (?s ω' !! n) = x  ev_at (HLD D) i ω)"
        proof cases
          assume "ev_at (HLD D) i ω"
          from ev_at_imp_snth[OF this]
          have eq: "snd (ω !! i) = Some (fst (ω !! i))"
            by (simp add: D_def HLD_iff)

          have "𝒫(ω' in KN.T (ω !! i). fst (ω' !! (n - Suc i)) = x) =
            𝒫(ω' in T (fst (ω !! i)). ω' !! (n - Suc i) = x) * 𝒫(ω' in K2.T (snd (ω !! i)). True)"
            by (subst KN.prod_eq_prob_T) simp_all
          also have " = p (fst (ω !! i)) x (Suc (n - Suc i))"
            using K2.T.prob_space by (simp add: p_def)
          also have " = K2.p (snd (ω !! i)) (Some x) (Suc (n - Suc i))"
            by (simp add: K_p_eq eq)
          also have " = 𝒫(ω' in T (fst (ω !! i)). True) * 𝒫(ω' in K2.T (snd (ω !! i)). ω' !! (n - Suc i) = Some x)"
            using T.prob_space by (simp add: K2.p_def)
          also have " = 𝒫(ω' in KN.T (ω !! i). snd (ω' !! (n - Suc i)) = Some x)"
            by (subst KN.prod_eq_prob_T) simp_all
          finally show ?thesis using ‹ev_at (HLD D) i ω i
            by (simp del: stake.simps)
        qed simp
      qed
    qed
    also have " = 𝒫(ω in KN.T (y, None). (i<n. fst (ω !! n) = x  ev_at (HLD D) i ω))"
      by (subst KN.T.finite_measure_finite_Union[symmetric])
         (auto simp add: disjoint_family_on_def dest: ev_at_unique
               intro!: arg_cong2[where f=measure])
    finally have eq: "𝒫(ω in KN.T (y, None). (i<n. snd (ω !! n) = Some x  ev_at (HLD D) i ω)) =
      𝒫(ω in KN.T (y, None). (i<n. fst (ω !! n) = x  ev_at (HLD D) i ω))" .

    have "p y x (Suc n) - measure N {x} = 𝒫(ω in T y. ω !! n = x) - 𝒫(ω in K2.T None. ω !! n = Some x)"
      unfolding p_def by (subst measure_y_eq) simp_all
    also have "𝒫(ω in T y. ω !! n = x) = 𝒫(ω in T y. ω !! n = x) * 𝒫(ω in K2.T None. True)"
      using K2.T.prob_space by simp
    also have " = 𝒫(ω in KN.T (y, None). fst (ω !! n) = x)"
      by (subst KN.prod_eq_prob_T) auto
    also have " = 𝒫(ω in KN.T (y, None). (i<n. fst (ω !! n) = x  ev_at (HLD D) i ω)) +
      𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω))"
      by (subst KN.T.finite_measure_Union[symmetric])
         (auto intro!: arg_cong2[where f=measure])
    also have "𝒫(ω in K2.T None. ω !! n = Some x) = 𝒫(ω in T y. True) * 𝒫(ω in K2.T None. ω !! n = Some x)"
      using T.prob_space by simp
    also have " = 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x)"
      by (subst KN.prod_eq_prob_T) auto
    also have " = 𝒫(ω in KN.T (y, None). (i<n. snd (ω !! n) = Some x  ev_at (HLD D) i ω)) +
      𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω))"
      by (subst KN.T.finite_measure_Union[symmetric])
         (auto intro!: arg_cong2[where f=measure])
    finally have "¦ p y x (Suc n) - measure N {x} ¦ =
      ¦ 𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω)) -
      𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω)) ¦"
      unfolding eq by (simp add: field_simps)
    also have "  ¦ 𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω)) ¦ +
      ¦ 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω)) ¦"
      by (rule abs_triangle_ineq4)
    also have "  𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω)) +
      𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω))"
      by simp
    finally have "¦ p y x (Suc n) - measure N {x} ¦  " . }
  note mono = this

  { fix n :: nat
    have "(+x. ¦ p y x (Suc n) - measure N {x} ¦ count_space C) 
      (+x. ennreal (𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω))) +
      ennreal (𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω))) count_space C)"
      using mono by (intro nn_integral_mono) (simp add: ennreal_plus[symmetric] del: ennreal_plus)
    also have " = (+x. 𝒫(ω in KN.T (y, None). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω)) count_space C) +
      (+x. 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω)) count_space C)"
      by (subst nn_integral_add) auto
    also have " = emeasure (KN.T (y, None)) (xC. {ωspace (KN.T (y, None)). fst (ω !! n) = x  ¬ (i<n. ev_at (HLD D) i ω)}) +
      emeasure (KN.T (y, None)) (xC. {ωspace (KN.T (y, None)). snd (ω !! n) = Some x  ¬ (i<n. ev_at (HLD D) i ω)})"
      by (subst (1 2) emeasure_UN_countable)
         (auto simp add: disjoint_family_on_def KN.T.emeasure_eq_measure C)
    also have "  ennreal (𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω))) + ennreal (𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω)))"
      unfolding KN.T.emeasure_eq_measure
      by (intro add_mono) (auto intro!: KN.T.finite_measure_mono)
    also have "  2 * 𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω))"
      by (simp add: ennreal_plus[symmetric] del: ennreal_plus)
    finally have "?L (Suc n)  2 * 𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω))"
      by (auto intro!: integral_real_bounded simp add: pmf.rep_eq) }
  note le_2 = this

  have c0_D: "(c0, Some c0)  D"
    by (simp add: D_def c0)

  let ?N' = "map_pmf Some N"
  interpret NP: pair_prob_space N ?N' ..

  have pos_recurrent: "xC × Some ` C. KN.pos_recurrent x"
  proof (rule KN.stationary_distributionD(1)[OF KN_essential _ KN.stationary_distributionI_pair[OF N(1)]])
    show "K2.stationary_distribution ?N'"
      unfolding K2.stationary_distribution_def
      by (subst N(1)[unfolded stationary_distribution_def])
         (auto intro!: bind_pmf_cong simp: K'_def map_pmf_def bind_assoc_pmf bind_return_pmf)
    show "countable (C × Some`C)"
      using C by auto
    show "set_pmf (pair_pmf N (map_pmf Some N))  C × Some ` C"
      using N  C by auto
  qed

  from c0_D have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω)  𝒫(ω in KN.T (y, None). alw (not (HLD {(c0, Some c0)})) ω)"
    apply (auto intro!: KN.T.finite_measure_mono)
    apply (rule alw_mono, assumption)
    apply (auto simp: HLD_iff)
    done
  also have " = 0"
    apply (rule KN.T.prob_eq_0_AE)
    apply (simp add: not_ev_iff[symmetric])
    apply (subst KN.AE_T_iff)
    apply simp
  proof
    fix t assume t: "t  KN.Kp (y, None)"
    then obtain a b where t_eq: "t = (a, Some b)" "a  K y" "b  N"
      unfolding KN.Kp_def by (auto simp: K'_def)
    with y  C have "a  C"
      using essential_classD2[OF ‹essential_class C y  C] by auto
    have "b  C"
      using N  C b  N by auto

    from pos_recurrent[THEN bspec, of "(c0, Some c0)"]
    have recurrent_c0: "KN.recurrent (c0, Some c0)"
      by (simp add: KN.pos_recurrent_def c0)
    have "C × Some ` C  UNIV // KN.communicating"
      using aperiodic by (simp add: KN.aperiodic_def)
    then have "((c0, Some c0), t)  KN.communicating"
      by (rule KN.irreducibleD) (simp_all add: t_eq c0 b  C a  C)
    then have "((c0, Some c0), t)  KN.acc"
      by (simp add: KN.communicating_def)
    then have "KN.U t (c0, Some c0) = 1"
      by (rule KN.recurrent_acc(1)[OF recurrent_c0])
    then show "AE ω in KN.T t. ev (HLD {(c0, Some c0)}) (t ## ω)"
      unfolding KN.U_def by (subst (asm) KN.T.prob_Collect_eq_1) (auto simp add: ev_Stream)
  qed
  finally have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω) = 0"
    by (intro antisym measure_nonneg)

  have "(λn. 𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω))) 
    measure (KN.T (y, None)) (n. {ωspace (KN.T (y, None)). ¬ (i<n. ev_at (HLD D) i ω)})"
    by (rule KN.T.finite_Lim_measure_decseq) (auto simp: decseq_def)
  also have "(n. {ωspace (KN.T (y, None)). ¬ (i<n. ev_at (HLD D) i ω)}) =
    {ωspace (KN.T (y, None)). alw (not (HLD D)) ω}"
    by (auto simp: not_ev_iff[symmetric] ev_iff_ev_at)
  also have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω) = 0" by fact
  finally have *: "(λn. 2 * 𝒫(ω in KN.T (y, None). ¬ (i<n. ev_at (HLD D) i ω)))  0"
    by (intro tendsto_eq_intros) auto

  show ?thesis
    apply (rule LIMSEQ_imp_Suc)
    apply (rule tendsto_sandwich[OF _ _ tendsto_const *])
    using le_2
    apply (simp_all add: integral_nonneg_AE)
    done
qed

lemma stationary_distribution_imp_p_limit:
  assumes "aperiodic C" "essential_class C" and [simp]: "countable C"
  assumes N: "stationary_distribution N" "N  C"
  assumes [simp]: "x  C" "y  C"
  shows "p x y  pmf N y"
proof -
  define D where "D y n = ¦p x y n - pmf N y¦" for y n

  from stationary_distribution_imp_limit[OF assms(1,2,3,4,5,6)]
  have INT: "(λn. y. D y n count_space C)  0"
    unfolding D_def .

  { fix n
    have "D y n  (z. D y n * indicator {y} z count_space C)"
      by simp
    also have "  (y. D y n count_space C)"
      by (intro integral_mono)
         (auto split: split_indicator simp: D_def p_def disjoint_family_on_def
               intro!: Bochner_Integration.integrable_diff integrable_pmf T.integrable_measure)
    finally have "D y n  (y. D y n count_space C)" . }
  note * = this

  have D_nonneg: "n. 0  D y n" by (simp add: D_def)

  have "D y  0"
    by (rule tendsto_sandwich[OF _ _ tendsto_const INT])
       (auto simp: eventually_sequentially * D_nonneg)
  then show ?thesis
    using Lim_null[where l="pmf N y" and net=sequentially and f="p x y"]
    by (simp add: D_def [abs_def] tendsto_rabs_zero_iff)
qed

end

lemma (in MC_syntax) essential_classI2:
  assumes "X  {}"
  assumes accI: "x y. x  X  y  X  (x, y)  acc"
  assumes ED: "x y. x  X  y  set_pmf (K x)  y  X"
  shows "essential_class X"
proof (rule essential_classI)
  { fix x y assume "(x, y)  acc" "x  X"
    then show "y  X"
      by induct (auto dest: ED)}
  note accD = this
  from X  {} obtain x where "x  X" by auto
  from x  X show "X  UNIV // communicating"
    by (auto simp add: quotient_def Image_def communicating_def accI dest: accD intro!: exI[of _ x])
qed

end

Theory Markov_Decision_Process

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Markov Decision Processes›

theory Markov_Decision_Process
  imports Discrete_Time_Markov_Chain
begin

definition "some_elem s = (SOME x. x  s)"

lemma some_elem_ne: "s  {}  some_elem s  s"
  unfolding some_elem_def by (auto intro: someI)

subsection ‹Configurations›

text ‹

We want to construct a \emph{non-free} codatatype
  's cfg = Cfg (state: 's) (action: 's pmf) (cont: 's ⇒ 's cfg)›.
with the restriction
  @{term "state (cont cfg s) = s"}

hide_const cont

codatatype 's scheduler = Scheduler (action_sch: "'s pmf") (cont_sch: "'s  's scheduler")

lemma equivp_rel_prod: "equivp R  equivp Q  equivp (rel_prod R Q)"
  by (auto intro!: equivpI prod.rel_symp prod.rel_transp prod.rel_reflp elim: equivpE)

coinductive eq_scheduler :: "'s scheduler  's scheduler  bool"
where
  "D. action_sch sc1 = D  action_sch sc2 = D 
    (sD. eq_scheduler (cont_sch sc1 s) (cont_sch sc2 s))  eq_scheduler sc1 sc2"

lemma eq_scheduler_refl[intro]: "eq_scheduler sc sc"
  by (coinduction arbitrary: sc) auto

quotient_type 's cfg = "'s × 's scheduler" / "rel_prod (=) eq_scheduler"
proof (intro equivp_rel_prod equivpI reflpI sympI transpI)
  show "eq_scheduler sc1 sc2  eq_scheduler sc2 sc1" for sc1 sc2 :: "'s scheduler"
    by (coinduction arbitrary: sc1 sc2) (auto elim: eq_scheduler.cases)
  show "eq_scheduler sc1 sc2  eq_scheduler sc2 sc3  eq_scheduler sc1 sc3"
    for sc1 sc2 sc3 :: "'s scheduler"
    by (coinduction arbitrary: sc1 sc2 sc3)
       (subst (asm) (1 2) eq_scheduler.simps, auto)
qed auto

lift_definition state :: "'s cfg  's" is "fst"
  by auto

lift_definition action :: "'s cfg  's pmf" is "λ(s, sc). action_sch sc"
  by (force elim: eq_scheduler.cases)

lift_definition cont :: "'s cfg  's  's cfg" is
  "λ(s, sc) t. if t  action_sch sc then (t, cont_sch sc t) else
    (t, cont_sch sc (some_elem (action_sch sc)))"
  apply (simp add: rel_prod_conv split: prod.splits)
  apply (subst (asm) eq_scheduler.simps)
  apply (auto simp: Let_def set_pmf_not_empty[THEN some_elem_ne])
  done

lift_definition Cfg :: "'s  's pmf  ('s  's cfg)  's cfg" is
  "λs D c. (s, Scheduler D (λt. snd (c t)))"
  by (auto simp: rel_prod_conv split_beta' eq_scheduler.simps[of "Scheduler _  _"])

lift_definition cfg_corec :: "'s  ('a  's pmf)  ('a  's  'a)   'a  's cfg" is
  "λs D C x. (s, corec_scheduler D (λx s. Inr (C x s)) x)"  .

lemma state_cont[simp]: "state (cont cfg s) = s"
  by transfer (simp split: prod.split)

lemma state_Cfg[simp]: "state (Cfg s d' c') = s"
  by transfer simp

lemma action_Cfg[simp]: "action (Cfg s d' c') = d'"
  by transfer simp

lemma cont_Cfg[simp]: "t  set_pmf d'  state (c' t) = t  cont (Cfg s d' c') t = c' t"
  by transfer (auto simp add: rel_prod_conv split: prod.split)

lemma state_cfg_corec[simp]: "state (cfg_corec s d c x) = s"
  by transfer auto

lemma action_cfg_corec[simp]: "action (cfg_corec s d c x) = d x"
  by transfer auto

lemma cont_cfg_corec[simp]: "t  set_pmf (d x)  cont (cfg_corec s d c x) t = cfg_corec t d c (c x t)"
  by transfer auto

lemma cfg_coinduct[consumes 1, case_names state action cont, coinduct pred]:
  "X c d  (c d. X c d  state c = state d)  (c d. X c d  action c = action d) 
    (c d t. X c d  t  set_pmf (action c)  X (cont c t) (cont d t))  c = d"
proof (transfer, clarsimp)
  fix X :: "('a × 'a scheduler)  ('a × 'a scheduler)  bool" and B s1 s2 sc1 sc2
  assume X: "X (s1, sc1) (s2, sc2)" and "rel_fun cr_cfg (rel_fun cr_cfg (=)) X B"
    and 1: "s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2)  s1 = s2"
    and 2: "s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2)  action_sch sc1 = action_sch sc2"
    and 3: "s1 sc1 s2 sc2 t. X (s1, sc1) (s2, sc2)  t  set_pmf (action_sch sc2) 
      X (t, cont_sch sc1 t) (t, cont_sch sc2 t)"
  from X show "eq_scheduler sc1 sc2"
    by (coinduction arbitrary: s1 s2 sc1 sc2)
       (blast dest: 2 3)
qed

coinductive rel_cfg :: "('a  'b  bool)  'a cfg  'b cfg  bool" for P :: "'a  'b  bool"
where
  "P (state cfg1) (state cfg2) 
    rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2) 
    rel_cfg P cfg1 cfg2"

lemma rel_cfg_state: "rel_cfg P cfg1 cfg2  P (state cfg1) (state cfg2)"
  by (auto elim: rel_cfg.cases)

lemma rel_cfg_cont:
  "rel_cfg P cfg1 cfg2 
    rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
  by (auto elim: rel_cfg.cases)

lemma rel_cfg_action:
  assumes P: "rel_cfg P cfg1 cfg2" shows "rel_pmf P (action cfg1) (action cfg2)"
proof (rule pmf.rel_mono_strong)
  show "rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
    using P by (rule rel_cfg_cont)
qed (auto dest: rel_cfg_state)

lemma rel_cfg_eq: "rel_cfg (=) cfg1 cfg2  cfg1 = cfg2"
proof safe
  show "rel_cfg (=) cfg1 cfg2  cfg1 = cfg2"
  proof (coinduction arbitrary: cfg1 cfg2)
    case cont
    have "action cfg1 = action cfg2"
      using ‹rel_cfg (=) cfg1 cfg2 by (auto dest: rel_cfg_action simp: pmf.rel_eq)
    then have "rel_pmf (λs t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg1)"
      using cont by (auto dest: rel_cfg_cont)
    then have "rel_pmf (λs t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t)  s = t) (action cfg1) (action cfg1)"
      by (rule pmf.rel_mono_strong) (auto dest: rel_cfg_state)
    then have "pred_pmf (λs. rel_cfg (=) (cont cfg1 s) (cont cfg2 s)) (action cfg1)"
      unfolding pmf.pred_rel by (rule pmf.rel_mono_strong) (auto simp: eq_onp_def)
    with t  action cfg1 show ?case
      by (auto simp: pmf.pred_set)
  qed (auto dest: rel_cfg_state rel_cfg_action simp: pmf.rel_eq)
  show "rel_cfg (=) cfg2 cfg2"
    by (coinduction arbitrary: cfg2) (auto intro!: rel_pmf_reflI)
qed

subsection ‹Configuration with Memoryless Scheduler›

definition "memoryless_on f s = cfg_corec s f (λ_ t. t) s"

lemma
  shows state_memoryless_on[simp]: "state (memoryless_on f s) = s"
    and action_memoryless_on[simp]: "action (memoryless_on f s) = f s"
    and cont_memoryless_on[simp]: "t  (f s)  cont (memoryless_on f s) t = memoryless_on f t"
  by (simp_all add: memoryless_on_def)

definition K_cfg :: "'s cfg  's cfg pmf" where
  "K_cfg cfg = map_pmf (cont cfg) (action cfg)"

lemma set_K_cfg: "set_pmf (K_cfg cfg) = cont cfg ` set_pmf (action cfg)"
  by (simp add: K_cfg_def)

lemma nn_integral_K_cfg: "(+cfg. f cfg K_cfg cfg) = (+s. f (cont cfg s) action cfg)"
  by (simp add: K_cfg_def map_pmf_rep_eq nn_integral_distr)

subsection ‹MDP Kernel and Induced Configurations›

locale Markov_Decision_Process =
  fixes K :: "'s  's pmf set"
  assumes K_wf: "s. K s  {}"
begin

definition "E = (SIGMA s:UNIV. DK s. set_pmf D)"

coinductive cfg_onp :: "'s  's cfg  bool" where
  "s. state cfg = s  action cfg  K s  (t. t  action cfg  cfg_onp t (cont cfg t)) 
    cfg_onp s cfg"

definition "cfg_on s = {cfg. cfg_onp s cfg}"

lemma
  shows cfg_onD_action[intro, simp]: "cfg  cfg_on s  action cfg  K s"
    and cfg_onD_cont[intro, simp]: "cfg  cfg_on s  t  action cfg  cont cfg t  cfg_on t"
    and cfg_onD_state[simp]: "cfg  cfg_on s  state cfg = s"
    and cfg_onI: "state cfg = s  action cfg  K s  (t. t  action cfg  cont cfg t  cfg_on t)  cfg  cfg_on s"
  by (auto simp: cfg_on_def intro: cfg_onp.intros elim: cfg_onp.cases)

lemma cfg_on_coinduct[coinduct set: cfg_on]:
  assumes "P s cfg"
  assumes "cfg s. P s cfg  state cfg = s"
  assumes "cfg s. P s cfg  action cfg  K s"
  assumes "cfg s t. P s cfg  t  action cfg  P t (cont cfg t)"
  shows "cfg  cfg_on s"
  using assms cfg_onp.coinduct[of P s cfg] by (simp add: cfg_on_def)

lemma memoryless_on_cfg_onI:
  assumes "s. f s  K s"
  shows "memoryless_on f s  cfg_on s"
  by (coinduction arbitrary: s) (auto intro: assms)

lemma cfg_of_cfg_onI:
  "D  K s  (t. t  D  c t  cfg_on t)  Cfg s D c  cfg_on s"
  by (rule cfg_onI) auto

definition "arb_act s = (SOME D. D  K s)"

lemma arb_actI[simp]: "arb_act s  K s"
  by (simp add: arb_act_def some_in_eq K_wf)

lemma cfg_on_not_empty[intro, simp]: "cfg_on s  {}"
  by (auto intro: memoryless_on_cfg_onI arb_actI)

sublocale MC: MC_syntax K_cfg .

abbreviation St :: "'s stream measure" where
  "St  stream_space (count_space UNIV)"

subsection ‹Trace Space›

definition "T cfg = distr (MC.T cfg) St (smap state)"

sublocale T: prob_space "T cfg" for cfg
  by (simp add: T_def MC.T.prob_space_distr)

lemma space_T[simp]: "space (T cfg) = space St"
  by (simp add: T_def)

lemma sets_T[simp]: "sets (T cfg) = sets St"
  by (simp add: T_def)

lemma measurable_T1[simp]: "measurable (T cfg) N = measurable St N"
  by (simp add: T_def)

lemma measurable_T2[simp]: "measurable N (T cfg) = measurable N St"
  by (simp add: T_def)

lemma nn_integral_T:
  assumes [measurable]: "f  borel_measurable St"
  shows "(+X. f X T cfg) = (+cfg'. (+x. f (state cfg' ## x) T cfg') K_cfg cfg)"
  by (simp add: T_def MC.nn_integral_T[of _ cfg] nn_integral_distr)

lemma T_eq:
  "T cfg = (measure_pmf (K_cfg cfg)  (λcfg'. distr (T cfg') St (λω. state cfg' ## ω)))"
proof (rule measure_eqI)
  fix A assume "A  sets (T cfg)"
  then show "emeasure (T cfg) A =
    emeasure (measure_pmf (K_cfg cfg)  (λcfg'. distr (T cfg') St (λω. state cfg' ## ω))) A"
    by (subst emeasure_bind[where N=St])
       (auto simp: space_subprob_algebra nn_integral_distr nn_integral_indicator[symmetric] nn_integral_T[of _ cfg]
             simp del: nn_integral_indicator intro!: prob_space_imp_subprob_space T.prob_space_distr)
qed simp

lemma T_memoryless_on: "T (memoryless_on ct s) = MC_syntax.T ct s"
proof -
  interpret ct: MC_syntax ct .
  have "T  (memoryless_on ct) = MC_syntax.T ct"
  proof (rule ct.T_bisim[symmetric])
    fix s show "(T  memoryless_on ct) s =
        measure_pmf (ct s)  (λs. distr ((T  memoryless_on ct) s) St ((##) s))"
      by (auto simp add: T_eq[of "memoryless_on ct s"] K_cfg_def map_pmf_rep_eq bind_distr[where K=St]
                         space_subprob_algebra T.prob_space_distr prob_space_imp_subprob_space
               intro!: bind_measure_pmf_cong)
  qed (simp_all, intro_locales)
  then show ?thesis by (simp add: fun_eq_iff)
qed

lemma nn_integral_T_lfp:
  assumes [measurable]: "case_prod g  borel_measurable (count_space UNIV M borel)"
  assumes cont_g: "s. sup_continuous (g s)"
  assumes int_g: "f cfg. f  borel_measurable (stream_space (count_space UNIV)) 
    (+ω. g (state cfg) (f ω) T cfg) = g (state cfg) (+ω. f ω T cfg)"
  shows "(+ω. lfp (λf ω. g (shd ω) (f (stl ω))) ω T cfg) =
    lfp (λf cfg. +t. g (state t) (f t) K_cfg cfg) cfg"
proof (rule nn_integral_lfp)
  show "s. sets (T s) = sets St"
      "F. F  borel_measurable St  (λa. g (shd a) (F (stl a)))  borel_measurable St"
    by auto
next
  fix s and F :: "'s stream  ennreal" assume "F  borel_measurable St"
  then show "(+ a. g (shd a) (F (stl a)) T s) =
           (+ cfg. g (state cfg) (integralN (T cfg) F) K_cfg s)"
    by (rewrite nn_integral_T) (simp_all add: int_g)
qed (auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])

lemma emeasure_Collect_T:
  assumes [measurable]: "Measurable.pred St P"
  shows "emeasure (T cfg) {xspace St. P x} =
    (+cfg'. emeasure (T cfg') {xspace St. P (state cfg' ## x)} K_cfg cfg)"
  using MC.emeasure_Collect_T[of "λx. P (smap state x)" cfg]
  by (simp add: nn_integral_distr emeasure_Collect_distr T_def)

definition E_sup :: "'s  ('s stream  ennreal)  ennreal"
where
  "E_sup s f = (cfgcfg_on s. +x. f x T cfg)"

lemma E_sup_const: "0  c  E_sup s (λ_. c) = c"
  using T.emeasure_space_1 by (simp add: E_sup_def)

lemma E_sup_mult_right:
  assumes [measurable]: "f  borel_measurable St" and [simp]: "0  c"
  shows "E_sup s (λx. c * f x) = c * E_sup s f"
  by (simp add: nn_integral_cmult E_sup_def SUP_mult_left_ennreal)

lemma E_sup_mono:
  "(ω. f ω  g ω)  E_sup s f  E_sup s g"
  unfolding E_sup_def by (intro SUP_subset_mono order_refl nn_integral_mono)

lemma E_sup_add:
  assumes [measurable]: "f  borel_measurable St" "g  borel_measurable St"
  shows "E_sup s (λx. f x + g x)  E_sup s f + E_sup s g"
proof -
  have "E_sup s (λx. f x + g x) = (cfgcfg_on s. (+x. f x T cfg) + (+x. g x T cfg))"
    by (simp add: E_sup_def nn_integral_add)
  also have "  (cfgcfg_on s. +x. f x T cfg) + (cfgcfg_on s. (+x. g x T cfg))"
    by (auto simp: SUP_le_iff intro!: add_mono SUP_upper)
  finally show ?thesis
    by (simp add: E_sup_def)
qed

lemma E_sup_add_left:
  assumes [measurable]: "f  borel_measurable St"
  shows "E_sup s (λx. f x + c) = E_sup s f + c"
  by (simp add: nn_integral_add E_sup_def T.emeasure_space_1[simplified] ennreal_SUP_add_left)

lemma E_sup_add_right:
  "f  borel_measurable St  E_sup s (λx. c + f x) = c + E_sup s f"
  using E_sup_add_left[of f s c] by (simp add: add.commute)

lemma E_sup_SUP:
  assumes [measurable]: "i. f i  borel_measurable St" and [simp]: "incseq f"
  shows "E_sup s (λx. i. f i x) = (i. E_sup s (f i))"
  by (auto simp add: E_sup_def nn_integral_monotone_convergence_SUP intro: SUP_commute)

lemma E_sup_iterate:
  assumes [measurable]: "f  borel_measurable St"
  shows "E_sup s f = (DK s. + t. E_sup t (λω. f (t ## ω)) measure_pmf D)"
proof -
  let ?v = "λt. +x. f (state t ## x) T t"
  let ?p = "λt. E_sup t (λω. f (t ## ω))"
  have "E_sup s f = (cfgcfg_on s. +t. ?v t K_cfg cfg)"
    unfolding E_sup_def by (intro SUP_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
  also have " = (DK s. +t. ?p t measure_pmf D)"
  proof (intro antisym SUP_least)
    fix cfg :: "'s cfg" assume cfg: "cfg  cfg_on s"
    then show "(+ t. ?v t K_cfg cfg)  (SUP DK s. +t. ?p t measure_pmf D)"
      by (auto simp: E_sup_def nn_integral_K_cfg AE_measure_pmf_iff
               intro!: nn_integral_mono_AE SUP_upper2)
  next
    fix D assume D: "D  K s" show "(+t. ?p t D)  (SUP cfg  cfg_on s. + t. ?v t K_cfg cfg)"
    proof cases
      assume p_finite: "tD. ?p t < "
      show ?thesis
      proof (rule ennreal_le_epsilon)
        fix e :: real assume "0 < e"
        have "tD. cfgcfg_on t. ?p t  ?v cfg + e"
        proof
          fix t assume "t  D"
          moreover have "(SUP cfg  cfg_on t. ?v cfg) = ?p t"
            unfolding E_sup_def by (simp add: cfg_on_def)
          ultimately have "(SUP cfg  cfg_on t. ?v cfg)  "
            using p_finite by auto
          from SUP_approx_ennreal[OF 0<e _ refl this]
          show "cfgcfg_on t. ?p t  ?v cfg + e"
            by (auto simp add: E_sup_def intro: less_imp_le)
        qed
        then obtain cfg' where v_cfg': "t. t  D  ?p t  ?v (cfg' t) + e" and
          cfg_on_cfg': "t. t  D  cfg' t  cfg_on t"
          unfolding Bex_def bchoice_iff by blast

        let ?cfg = "Cfg s D cfg'"
        have cfg: "K_cfg ?cfg = map_pmf cfg' D"
          by (auto simp add: K_cfg_def fun_eq_iff cfg_on_cfg' intro!: map_pmf_cong)

        have "(+ t. ?p t D)  (+t. ?v (cfg' t) + e D)"
          by (intro nn_integral_mono_AE) (simp add: v_cfg' AE_measure_pmf_iff)
        also have " = (+t. ?v (cfg' t) D) + e"
          using 0 < e measure_pmf.emeasure_space_1[of D]
          by (subst nn_integral_add) (auto intro: cfg_on_cfg' )
        also have "(+t. ?v (cfg' t) D) = (+t. ?v t K_cfg ?cfg)"
          by (simp add: cfg map_pmf_rep_eq nn_integral_distr)
        also have "  (SUP cfgcfg_on s. (+t. ?v t K_cfg cfg))"
          by (auto intro!: SUP_upper intro!: cfg_of_cfg_onI D cfg_on_cfg')
        finally show "(+ t. ?p t D)  (SUP cfg  cfg_on s. + t. ?v t K_cfg cfg) + e"
          by (blast intro: add_mono)
      qed
    next
      assume "¬ (tD. ?p t < )"
      then obtain t where "t  D" "?p t = "
        by (auto simp: not_less top_unique)
      then have " = pmf (D) t * ?p t"
        by (auto simp: ennreal_mult_top set_pmf_iff)
      also have " = (SUP cfg  cfg_on t. pmf (D) t * ?v cfg)"
        unfolding E_sup_def
        by (auto simp: SUP_mult_left_ennreal[symmetric])
      also have "  (SUP cfg  cfg_on s. + t. ?v t K_cfg cfg)"
        unfolding E_sup_def
      proof (intro SUP_least SUP_upper2)
        fix cfg :: "'s cfg" assume cfg: "cfg  cfg_on t"

        let ?cfg = "Cfg s D ((memoryless_on arb_act) (t := cfg))"
        have C: "K_cfg ?cfg = map_pmf ((memoryless_on arb_act) (t := cfg)) D"
          by (auto simp add: K_cfg_def fun_eq_iff intro!: map_pmf_cong simp: cfg)

        show "?cfg  cfg_on s"
          by (auto intro!: cfg_of_cfg_onI D cfg memoryless_on_cfg_onI)
        have "ennreal (pmf (D) t) * (+ x. f (state cfg ## x) T cfg) =
          (+t'. (+ x. f (state cfg ## x) T cfg) * indicator {t} t' D)"
          by (auto simp add:  max_def emeasure_pmf_single intro: mult_ac)
        also have " = (+cfg. ?v cfg * indicator {t} (state cfg) K_cfg ?cfg)"
          unfolding C using cfg
          by (auto simp add: nn_integral_distr map_pmf_rep_eq split: split_indicator
                   simp del: nn_integral_indicator_singleton
                   intro!: nn_integral_cong)
        also have "  (+cfg. ?v cfg K_cfg ?cfg)"
          by (auto intro!: nn_integral_mono  split: split_indicator)
        finally show "ennreal (pmf (D) t) * (+ x. f (state cfg ## x) T cfg)
            (+ t. + x. f (state t ## x) T t K_cfg ?cfg)" .
      qed
      finally show ?thesis
        by (simp add: top_unique del: Sup_eq_top_iff SUP_eq_top_iff)
    qed
  qed
  finally show ?thesis .
qed

lemma E_sup_bot: "E_sup s  = 0"
  by (auto simp add: E_sup_def bot_ennreal)

lemma E_sup_lfp:
  fixes g
  defines "l  λf ω. g (shd ω) (f (stl ω))"
  assumes measurable_g[measurable]: "case_prod g  borel_measurable (count_space UNIV M borel)"
  assumes cont_g: "s. sup_continuous (g s)"
  assumes int_g: "f cfg. f  borel_measurable St 
     (+ ω. g (state cfg) (f ω) T cfg) = g (state cfg) (integralN (T cfg) f)"
  shows "(λs. E_sup s (lfp l)) = lfp (λf s. DK s. +t. g t (f t) measure_pmf D)"
proof (rule lfp_transfer_bounded[where α="λF s. E_sup s F" and f=l and P="λf. f  borel_measurable St"])
  show "sup_continuous (λf s. xK s. + t. g t (f t) measure_pmf x)"
    using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros)
  show "sup_continuous l"
    using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros simp: l_def)
  show "F. (λs. E_sup s )  (λs. DK s. + t. g t (F t) measure_pmf D)"
    using K_wf by (auto simp: E_sup_bot le_fun_def intro: SUP_upper2 )
next
  fix f :: "'s stream  ennreal" assume f: "f  borel_measurable St"
  moreover
  have "E_sup s (λω. g s (f ω)) = g s (E_sup s f)" for s
    unfolding E_sup_def using int_g[OF f]
    by (subst SUP_sup_continuous_ennreal[OF cont_g, symmetric])
       (auto intro!: SUP_cong simp del: cfg_onD_state dest: cfg_onD_state[symmetric])
  ultimately show "(λs. E_sup s (l f)) = (λs. DK s. + t. g t (E_sup t f) measure_pmf D)"
    by (subst E_sup_iterate) (auto simp: l_def int_g fun_eq_iff intro!: SUP_cong nn_integral_cong)
qed (auto simp: bot_fun_def l_def SUP_apply[abs_def] E_sup_SUP)

definition "P_sup s P = (cfgcfg_on s. emeasure (T cfg) {xspace St. P x})"

lemma P_sup_eq_E_sup:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_sup s P = E_sup s (indicator {xspace St. P x})"
  by (auto simp add: P_sup_def E_sup_def intro!: SUP_cong nn_integral_cong)

lemma P_sup_True[simp]: "P_sup t (λω. True) = 1"
  using T.emeasure_space_1
  by (auto simp add: P_sup_def SUP_constant)

lemma P_sup_False[simp]: "P_sup t (λω. False) = 0"
  by (auto simp add: P_sup_def SUP_constant)

lemma P_sup_SUP:
  fixes P :: "nat  's stream  bool"
  assumes "mono P" and P[measurable]: "i. Measurable.pred St (P i)"
  shows "P_sup s (λx. i. P i x) = (i. P_sup s (P i))"
proof -
  have "P_sup s (λx. i. P i x) = (cfgcfg_on s. emeasure (T cfg) (i. {xspace St. P i x}))"
    by (auto simp: P_sup_def intro!: SUP_cong arg_cong2[where f=emeasure])
  also have " = (cfgcfg_on s. i. emeasure (T cfg) {xspace St. P i x})"
    using ‹mono P by (auto intro!: SUP_cong SUP_emeasure_incseq[symmetric] simp: mono_def le_fun_def)
  also have " = (i. P_sup s (P i))"
    by (subst SUP_commute) (simp add: P_sup_def)
  finally show ?thesis
    by simp
qed

lemma P_sup_lfp:
  assumes Q: "sup_continuous Q"
  assumes f: "f  measurable St M"
  assumes Q_m: "P. Measurable.pred M P  Measurable.pred M (Q P)"
  shows "P_sup s (λx. lfp Q (f x)) = (i. P_sup s (λx. (Q ^^ i)  (f x)))"
  unfolding sup_continuous_lfp[OF Q]
  apply simp
proof (rule P_sup_SUP)
  fix i show "Measurable.pred St (λx. (Q ^^ i)  (f x))"
    apply (intro measurable_compose[OF f])
    by (induct i) (auto intro!: Q_m)
qed (intro mono_funpow sup_continuous_mono[OF Q] mono_compose[where f=f])

lemma P_sup_iterate:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_sup s P = (DK s. + t. P_sup t (λω. P (t ## ω)) measure_pmf D)"
proof -
  have [simp]: "x s. indicator {x  space St. P x} (x ## s) = indicator {s  space St. P (x ## s)} s"
    by (auto simp: space_stream_space split: split_indicator)
  show ?thesis
    using E_sup_iterate[of "indicator {xspace St. P x}" s] by (auto simp: P_sup_eq_E_sup)
qed

definition "E_inf s f = (cfgcfg_on s. +x. f x T cfg)"

lemma E_inf_const: "0  c  E_inf s (λ_. c) = c"
  using T.emeasure_space_1 by (simp add: E_inf_def)

lemma E_inf_mono:
  "(ω. f ω  g ω)  E_inf s f  E_inf s g"
  unfolding E_inf_def by (intro INF_superset_mono order_refl nn_integral_mono)

lemma E_inf_iterate:
  assumes [measurable]: "f  borel_measurable St"
  shows "E_inf s f = (DK s. + t. E_inf t (λω. f (t ## ω)) measure_pmf D)"
proof -
  let ?v = "λt. +x. f (state t ## x) T t"
  let ?p = "λt. E_inf t (λω. f (t ## ω))"
  have "E_inf s f = (cfgcfg_on s. +t. ?v t K_cfg cfg)"
    unfolding E_inf_def by (intro INF_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
  also have " = (DK s. +t. ?p t measure_pmf D)"
  proof (intro antisym INF_greatest)
    fix cfg :: "'s cfg" assume cfg: "cfg  cfg_on s"
    then show "(INF DK s. +t. ?p t measure_pmf D)  (+ t. ?v t K_cfg cfg)"
      by (auto simp add: E_inf_def nn_integral_K_cfg AE_measure_pmf_iff intro!: nn_integral_mono_AE INF_lower2)
  next
    fix D assume D: "D  K s" show "(INF cfg  cfg_on s. + t. ?v t K_cfg cfg)  (+t. ?p t D)"
    proof (rule ennreal_le_epsilon)
      fix e :: real assume "0 < e"
      have "tD. cfgcfg_on t. ?v cfg  ?p t + e"
      proof
        fix t assume "t  D"
        show "cfgcfg_on t. ?v cfg  ?p t + e"
        proof cases
          assume "?p t = " with cfg_on_not_empty[of t] show ?thesis
            by (auto simp: top_add simp del: cfg_on_not_empty)
        next
          assume p_finite: "?p t  "
          note t  D
          moreover have "(INF cfg  cfg_on t. ?v cfg) = ?p t"
            unfolding E_inf_def by (simp add: cfg_on_def)
          ultimately have "(INF cfg  cfg_on t. ?v cfg)  "
            using p_finite by auto
          from INF_approx_ennreal[OF 0 < e refl this]
          show "cfgcfg_on t. ?v cfg  ?p t + e"
            by (auto simp: E_inf_def intro: less_imp_le)
        qed
      qed
      then obtain cfg' where v_cfg': "t. t  D  ?v (cfg' t)  ?p t + e" and
        cfg_on_cfg': "t. t  D  cfg' t  cfg_on t"
        unfolding Bex_def bchoice_iff by blast

      let ?cfg = "Cfg s D cfg'"

      have cfg: "K_cfg ?cfg = map_pmf cfg' D"
        by (auto simp add: K_cfg_def cfg_on_cfg' intro!: map_pmf_cong)

      have "?cfg  cfg_on s"
        by (auto intro: D cfg_on_cfg' cfg_of_cfg_onI)
      then have "(INF cfg  cfg_on s. + t. ?v t K_cfg cfg)  (+ t. ?p t + e D)"
        by (rule INF_lower2) (auto simp: cfg map_pmf_rep_eq nn_integral_distr v_cfg' AE_measure_pmf_iff intro!: nn_integral_mono_AE)
      also have " = (+ t. ?p t D) + e"
        using 0 < e by (simp add: nn_integral_add measure_pmf.emeasure_space_1[simplified])
      finally show "(INF cfg  cfg_on s. + t. ?v t K_cfg cfg)  (+ t. ?p t D) + e" .
    qed
  qed
  finally show ?thesis .
qed

lemma emeasure_T_const[simp]: "emeasure (T s) (space St) = 1"
  using T.emeasure_space_1[of s] by simp

lemma E_inf_greatest:
  "(cfg. cfg  cfg_on s  x  (+x. f x T cfg))  x  E_inf s f"
  unfolding E_inf_def by (rule INF_greatest)

lemma E_inf_lower2:
  "cfg  cfg_on s  (+x. f x T cfg)  x  E_inf s f  x"
  unfolding E_inf_def by (rule INF_lower2)

text ‹
  Maybe the following statement can be generalized to infinite @{term "K s"}.
›

lemma E_inf_lfp:
  fixes g
  defines "l  λf ω. g (shd ω) (f (stl ω))"
  assumes measurable_g[measurable]: "case_prod g  borel_measurable (count_space UNIV M borel)"
  assumes cont_g: "s. sup_continuous (g s)"
  assumes int_g: "f cfg. f  borel_measurable St 
     (+ ω. g (state cfg) (f ω) T cfg) = g (state cfg) (integralN (T cfg) f)"
  assumes K_finite: "s. finite (K s)"
  shows "(λs. E_inf s (lfp l)) = lfp (λf s. DK s. +t. g t (f t) measure_pmf D)"
proof (rule antisym)
  let ?F = "λF s. DK s. + t. g t (F t) measure_pmf D"
  let ?I = "λD. (+t. g t (lfp ?F t) measure_pmf D)"
  have mono_F: "mono ?F"
    using sup_continuous_mono[OF cont_g]
    by (force intro!: INF_mono nn_integral_mono monoI simp: mono_def le_fun_def)
  define ct where "ct s = (SOME D. D  K s  (lfp ?F s = ?I D))" for s
  { fix s
    have "finite (?I ` K s)"
      by (auto intro: K_finite)
    then obtain D where "D  K s" "?I D = Min (?I ` K s)"
      by (auto simp: K_wf dest!: Min_in)
    note this(2)
    also have " = (INF D  K s. ?I D)"
      using K_wf by (subst Min_Inf) (auto intro: K_finite)
    also have " = lfp ?F s"
      by (rewrite in "_ = " lfp_unfold[OF mono_F]) auto
    finally have "D. D  K s  (lfp ?F s = ?I D)"
      using D  K s by auto
    then have "ct s  K s  (lfp ?F s = ?I (ct s))"
      unfolding ct_def by (rule someI_ex)
    then have "ct s  K s" "lfp ?F s = ?I (ct s)"
      by auto }
  note ct = this
  then have ct_cfg_on[simp]: "s. memoryless_on ct s  cfg_on s"
    by (intro memoryless_on_cfg_onI) simp
  then show "(λs. E_inf s (lfp l))  lfp ?F"
  proof (intro le_funI, rule E_inf_lower2)
    fix s
    define P where "P f cfg = + t. g (state t) (f t) K_cfg cfg" for f cfg
    have "integralN (T (memoryless_on ct s)) (lfp l) = lfp P (memoryless_on ct s)"
      unfolding P_def l_def using measurable_g cont_g int_g by (rule nn_integral_T_lfp)
    also have " = (SUP i. (P ^^ i) ) (memoryless_on ct s)"
      by (rewrite sup_continuous_lfp)
         (auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose] simp: P_def)
    also have " = (SUP i. (P ^^ i)  (memoryless_on ct s))"
      by (simp add: image_comp)
    also have "  lfp ?F s"
    proof (rule SUP_least)
      fix i show "(P ^^ i)  (memoryless_on ct s)  lfp ?F s"
      proof (induction i arbitrary: s)
        case 0 then show ?case
          by simp
      next
        case (Suc n)
        have "(P ^^ Suc n)  (memoryless_on ct s) =
          (+ t. g t ((P ^^ n)  (memoryless_on ct t)) ct s)"
          by (auto simp add: P_def K_cfg_def AE_measure_pmf_iff intro!: nn_integral_cong_AE)
        also have "  (+ t. g t (lfp ?F t) ct s)"
          by (intro nn_integral_mono sup_continuous_mono[OF cont_g, THEN monoD] Suc)
        also have " = lfp ?F s"
          by (rule  ct(2) [symmetric])
        finally show ?case .
      qed
    qed
    finally show "integralN (T (memoryless_on ct s)) (lfp l)  lfp ?F s" .
  qed

  have cont_l: "sup_continuous l"
    by (auto simp: l_def intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])

  show "lfp ?F  (λs. E_inf s (lfp l))"
  proof (intro lfp_lowerbound le_funI)
    fix s show "(xK s. + t. g t (E_inf t (lfp l)) measure_pmf x)  E_inf s (lfp l)"
    proof (rewrite in "_  " E_inf_iterate)
      show l: "lfp l  borel_measurable St"
        using cont_l by (rule borel_measurable_lfp) (simp add: l_def)
      show "(DK s. + t. g t (E_inf t (lfp l)) measure_pmf D) 
        (DK s. + t. E_inf t (λω. lfp l (t ## ω)) measure_pmf D)"
      proof (rule INF_mono nn_integral_mono bexI)+
        fix t D assume "D  K s"
        { fix cfg assume "cfg  cfg_on t"
          have "(+ ω. g (state cfg) (lfp l ω) T cfg) = g (state cfg) (+ ω. (lfp l ω) T cfg)"
            using l by (rule int_g)
          with cfg  cfg_on t have *: "(+ ω. g t (lfp l ω) T cfg) = g t (+ ω. (lfp l ω) T cfg)"
            by simp }
        then
        have *: "g t (cfgcfg_on t. integralN (T cfg) (lfp l))  (cfgcfg_on t. + ω. g t (lfp l ω) T cfg)"
          apply simp
          apply (rule INF_greatest)
          apply (rule sup_continuous_mono[OF cont_g, THEN monoD])
          apply (rule INF_lower)
          apply assumption
          done
        show "g t (E_inf t (lfp l))  E_inf t (λω. lfp l (t ## ω))"
          apply (rewrite in "_  " lfp_unfold[OF sup_continuous_mono[OF cont_l]])
          apply (rewrite in "_  " l_def)
          apply (simp add: E_inf_def *)
          done
      qed
    qed
  qed
qed

definition "P_inf s P = (cfgcfg_on s. emeasure (T cfg) {xspace St. P x})"

lemma P_inf_eq_E_inf:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_inf s P = E_inf s (indicator {xspace St. P x})"
  by (auto simp add: P_inf_def E_inf_def intro!: SUP_cong nn_integral_cong)

lemma P_inf_True[simp]: "P_inf t (λω. True) = 1"
  using T.emeasure_space_1
  by (auto simp add: P_inf_def SUP_constant)

lemma P_inf_False[simp]: "P_inf t (λω. False) = 0"
  by (auto simp add: P_inf_def SUP_constant)

lemma P_inf_INF:
  fixes P :: "nat  's stream  bool"
  assumes "decseq P" and P[measurable]: "i. Measurable.pred St (P i)"
  shows "P_inf s (λx. i. P i x) = (i. P_inf s (P i))"
proof -
  have "P_inf s (λx. i. P i x) = (cfgcfg_on s. emeasure (T cfg) (i. {xspace St. P i x}))"
    by (auto simp: P_inf_def intro!: INF_cong arg_cong2[where f=emeasure])
  also have " = (cfgcfg_on s. i. emeasure (T cfg) {xspace St. P i x})"
    using ‹decseq P by (auto intro!: INF_cong INF_emeasure_decseq[symmetric] simp: decseq_def le_fun_def)
  also have " = (i. P_inf s (P i))"
    by (subst INF_commute) (simp add: P_inf_def)
  finally show ?thesis
    by simp
qed

lemma P_inf_gfp:
  assumes Q: "inf_continuous Q"
  assumes f: "f  measurable St M"
  assumes Q_m: "P. Measurable.pred M P  Measurable.pred M (Q P)"
  shows "P_inf s (λx. gfp Q (f x)) = (i. P_inf s (λx. (Q ^^ i)  (f x)))"
  unfolding inf_continuous_gfp[OF Q]
  apply simp
proof (rule P_inf_INF)
  fix i show "Measurable.pred St (λx. (Q ^^ i)  (f x))"
    apply (intro measurable_compose[OF f])
    by (induct i) (auto intro!: Q_m)
next
  show "decseq (λi x. (Q ^^ i)  (f x))"
    using inf_continuous_mono[OF Q, THEN funpow_increasing[rotated]]
    unfolding decseq_def le_fun_def by auto
qed

lemma P_inf_iterate:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_inf s P = (DK s. + t. P_inf t (λω. P (t ## ω)) measure_pmf D)"
proof -
  have [simp]: "x s. indicator {x  space St. P x} (x ## s) = indicator {s  space St. P (x ## s)} s"
    by (auto simp: space_stream_space split: split_indicator)
  show ?thesis
    using E_inf_iterate[of "indicator {xspace St. P x}" s] by (auto simp: P_inf_eq_E_inf)
qed

end

subsection ‹Finite MDPs›

locale Finite_Markov_Decision_Process = Markov_Decision_Process K for K :: "'s  's pmf set" +
  fixes S :: "'s set"
  assumes S_not_empty: "S  {}"
  assumes S_finite: "finite S"
  assumes K_closed: "s. s  S  (DK s. set_pmf D)  S"
  assumes K_finite: "s. s  S  finite (K s)"
begin

lemma action_closed: "s  S  cfg  cfg_on s  t  action cfg  t  S"
  using cfg_onD_action[of cfg s] K_closed[of s] by auto

lemma set_pmf_closed: "s  S  D  K s  t  D  t  S"
  using K_closed by auto

lemma Pi_closed: "ct  Pi S K  s  S  t  ct s  t  S"
  using set_pmf_closed by auto

lemma E_closed: "s  S  (s, t)  E  t  S"
  using K_closed by (auto simp: E_def)

lemma set_pmf_finite: "s  S  D  K s  finite D"
  using K_closed by (intro finite_subset[OF _ S_finite]) auto

definition "valid_cfg = (sS. cfg_on s)"

lemma valid_cfgI: "s  S  cfg  cfg_on s  cfg  valid_cfg"
  by (auto simp: valid_cfg_def)

lemma valid_cfgD: "cfg  valid_cfg  cfg  cfg_on (state cfg)"
  by (auto simp: valid_cfg_def)

lemma
  shows valid_cfg_state_in_S: "cfg  valid_cfg  state cfg  S"
    and valid_cfg_action: "cfg  valid_cfg  s  action cfg  s  S"
    and valid_cfg_cont: "cfg  valid_cfg  s  action cfg  cont cfg s  valid_cfg"
  by (auto simp: valid_cfg_def intro!: bexI[of _ s] intro: action_closed)

lemma valid_K_cfg[intro]: "cfg  valid_cfg  cfg'  K_cfg cfg  cfg'  valid_cfg"
  by (auto simp add: K_cfg_def valid_cfg_cont)

definition "simple ct = memoryless_on (λs. if s  S then ct s else arb_act s)"

lemma simple_cfg_on[simp]: "ct  Pi S K  simple ct s  cfg_on s"
  by (auto simp: simple_def intro!: memoryless_on_cfg_onI)

lemma simple_valid_cfg[simp]: "ct  Pi S K  s  S  simple ct s  valid_cfg"
  by (auto intro: valid_cfgI)

lemma cont_simple[simp]: "s  S  t  set_pmf (ct s)  cont (simple ct s) t = simple ct t"
  by (simp add: simple_def)

lemma state_simple[simp]: "state (simple ct s) = s"
  by (simp add: simple_def)

lemma action_simple[simp]: "s  S  action (simple ct s) = ct s"
  by (simp add: simple_def)

lemma simple_valid_cfg_iff: "ct  Pi S K  simple ct s  valid_cfg  s  S"
  using cfg_onD_state[of "simple ct s"] by (auto simp add: valid_cfg_def intro!: bexI[of _ s])

end

end

Theory MDP_Reachability_Problem

theory MDP_Reachability_Problem
  imports Markov_Decision_Process
begin

inductive_set directed_towards :: "'a set  ('a × 'a) set  'a set" for A r where
  start: "x. x  A  x  directed_towards A r"
| step: "x y. y  directed_towards A r  (x, y)  r  x  directed_towards A r"

hide_fact (open) start step

lemma directed_towards_mono:
  assumes "s  directed_towards A F" "F  G" shows "s  directed_towards A G"
  using assms by induct (auto intro: directed_towards.intros)

lemma directed_eq_rtrancl: "x  directed_towards A r  (aA. (x, a)  r*)"
proof
  assume "x  directed_towards A r" then show "aA. (x, a)  r*"
    by induction (auto intro: converse_rtrancl_into_rtrancl)
next
  assume "aA. (x, a)  r*"
  then obtain a where "(x, a)  r*" "a  A" by auto
  then show "x  directed_towards A r"
    by (induction rule: converse_rtrancl_induct)
       (auto intro: directed_towards.start directed_towards.step)
qed

lemma directed_eq_rtrancl_Image: "directed_towards A r = (r*)¯ `` A"
  unfolding set_eq_iff directed_eq_rtrancl Image_iff by simp

locale Reachability_Problem = Finite_Markov_Decision_Process K S for K :: "'s  's pmf set" and S +
  fixes S1 S2 :: "'s set"
  assumes S1: "S1  S" and S2: "S2  S" and S1_S2: "S1  S2 = {}"
begin

lemma [measurable]:
  "S  sets (count_space UNIV)" "S1  sets (count_space UNIV)" "S2  sets (count_space UNIV)"
  by auto

definition
  "v = (λcfgvalid_cfg. emeasure (T cfg) {xspace St. (HLD S1 suntil HLD S2) (state cfg ## x)})"

lemma v_eq: "cfg  valid_cfg 
    v cfg = emeasure (T cfg) {xspace St. (HLD S1 suntil HLD S2) (state cfg ## x)}"
  by (auto simp add: v_def)

lemma real_v: "cfg  valid_cfg  enn2real (v cfg) = 𝒫(ω in T cfg. (HLD S1 suntil HLD S2) (state cfg ## ω))"
  by (auto simp add: v_def T.emeasure_eq_measure)

lemma v_le_1: "cfg  valid_cfg  v cfg  1"
  by (auto simp add: v_def T.emeasure_eq_measure)

lemma v_neq_Pinf[simp]: "cfg  valid_cfg  v cfg  top"
  by (auto simp add: v_def)

lemma v_1_AE: "cfg  valid_cfg  v cfg = 1  (AE ω in T cfg. (HLD S1 suntil HLD S2) (state cfg ## ω))"
  unfolding v_eq T.emeasure_eq_measure ennreal_eq_1 space_T[symmetric, of cfg]
  by (rule T.prob_Collect_eq_1) simp

lemma v_0_AE: "cfg  valid_cfg  v cfg = 0  (AE x in T cfg. not (HLD S1 suntil HLD S2) (state cfg ## x))"
  unfolding v_eq T.emeasure_eq_measure space_T[symmetric, of cfg] ennreal_eq_zero_iff[OF measure_nonneg]
  by (rule T.prob_Collect_eq_0) simp

lemma v_S2[simp]: "cfg  valid_cfg  state cfg  S2  v cfg = 1"
  using S2 by (subst v_1_AE) (auto simp: suntil_Stream)

lemma v_nS12[simp]: "cfg  valid_cfg  state cfg  S1  state cfg  S2  v cfg = 0"
  by (subst v_0_AE) (auto simp: suntil_Stream)

lemma v_nS[simp]: "cfg  valid_cfg  v cfg = undefined"
  by (auto simp add: v_def)

lemma v_S1:
  assumes cfg[simp, intro]: "cfg  valid_cfg" and cfg_S1[simp]: "state cfg  S1"
  shows "v cfg = (+s. v (cont cfg s) action cfg)"
proof -
  have [simp]: "state cfg  S2"
    using cfg_S1 S1_S2 S1 by blast
  show ?thesis
    by (auto simp: v_eq emeasure_Collect_T[of _ cfg] K_cfg_def map_pmf_rep_eq nn_integral_distr
                   AE_measure_pmf_iff suntil_Stream[of _ _ "state cfg"]
                   valid_cfg_cont
             intro!: nn_integral_cong_AE)
qed

lemma real_v_integrable:
  "integrable (action cfg) (λs. enn2real (v (cont cfg s)))"
  by (rule measure_pmf.integrable_const_bound[where B="max 1 (enn2real undefined)"])
     (auto simp add: v_def measure_def[symmetric] le_max_iff_disj)

lemma real_v_integral_eq:
  assumes cfg[simp]: "cfg  valid_cfg"
  shows "enn2real (+ s. v (cont cfg s) action cfg) =  s. enn2real (v (cont cfg s)) action cfg"
 by (subst integral_eq_nn_integral)
    (auto simp: AE_measure_pmf_iff v_eq T.emeasure_eq_measure valid_cfg_cont
          intro!: arg_cong[where f=enn2real] nn_integral_cong_AE)

lemma v_eq_0_coinduct[consumes 3, case_names valid nS2 cont]:
  assumes *: "P cfg"
  assumes valid: "cfg. P cfg  cfg  valid_cfg"
  assumes nS2: "cfg. P cfg  state cfg  S2"
  assumes cont: "cfg cfg'. P cfg  state cfg  S1  cfg'  K_cfg cfg  P cfg'  v cfg' = 0"
  shows "v cfg = 0"
proof -
  from * valid[OF *]
  have "AE x in MC_syntax.T K_cfg cfg. ¬ (HLD S1 suntil HLD S2) (state cfg ## smap state x)"
    unfolding stream.map[symmetric] suntil_smap hld_smap'
  proof (coinduction arbitrary: cfg rule: MC.AE_not_suntil_coinduct_strong)
    case (ψ cfg) then show ?case
      by (auto simp del: cfg_onD_state dest: nS2)
  next
    case (φ cfg' cfg)
    then have *: "P cfg" "state cfg  S1" "cfg'  K_cfg cfg" and [simp, intro]: "cfg  valid_cfg"
      by auto
    with cont[OF *] show ?case
      by (subst (asm) v_0_AE)
         (auto simp: suntil_Stream T_def AE_distr_iff suntil_smap hld_smap' cong del: AE_cong)
  qed
  then have "AE ω in T cfg. ¬ (HLD S1 suntil HLD S2) (state cfg ## ω)"
    unfolding T_def by (subst AE_distr_iff) simp_all
  with valid[OF *] show ?thesis
    by (simp add: v_0_AE)
qed


definition "p = (λsS. P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω)))"

lemma p_eq_SUP_v: "s  S  p s =  (v ` cfg_on s)"
  by (auto simp add: p_def v_def P_sup_def T.emeasure_eq_measure intro: valid_cfgI intro!: SUP_cong cong: SUP_cong_simp)

lemma v_le_p: "cfg  valid_cfg  v cfg  p (state cfg)"
  by (subst p_eq_SUP_v) (auto intro!: SUP_upper dest: valid_cfgD valid_cfg_state_in_S)

lemma p_eq_0_imp: "cfg  valid_cfg  p (state cfg) = 0  v cfg = 0"
  using v_le_p[of cfg] by (auto intro: antisym)

lemma p_eq_0_iff: "s  S  p s = 0  (cfgcfg_on s. v cfg = 0)"
  unfolding p_eq_SUP_v by (subst SUP_eq_iff) auto

lemma p_le_1: "s  S  p s  1"
  by (auto simp: p_eq_SUP_v intro!: SUP_least v_le_1 intro: valid_cfgI)

lemma p_undefined[simp]: "s  S  p s = undefined"
  by (simp add: p_def)

lemma p_not_inf[simp]: "s  S  p s  top"
  using p_le_1[of s] by (auto simp: top_unique)

lemma p_S1: "s  S1  p s = (DK s. + t. p t measure_pmf D)"
  using S1 S1_S2 K_closed[of s] unfolding p_def
  by (simp add: P_sup_iterate[of _ s] subset_eq set_eq_iff suntil_Stream[of _ _ s])
     (auto intro!: SUP_cong nn_integral_cong_AE simp add: AE_measure_pmf_iff)

lemma p_S2[simp]: "s  S2  p s = 1"
  using S2 by (auto simp: v_S2[OF valid_cfgI] p_eq_SUP_v)

lemma p_nS12: "s  S  s  S1  s  S2  p s = 0"
  by (auto simp: p_eq_SUP_v v_nS12[OF valid_cfgI])

lemma p_pos:
  assumes "(s, t)  (SIGMA s:S1. DK s. set_pmf D)*" "t  S2" shows "0 < p s"
using assms proof (induction rule: converse_rtrancl_induct)
  case (step s t')
  then obtain D where "s  S1" "D  K s" "t'  D" "0 < p t'"
    by auto
  with S1 set_pmf_closed[of s D] have in_S: "t. t  D  t  S"
    by auto
  from t'  D 0 < p t' have "0 < pmf D t' * p t'"
    by (auto simp add: ennreal_zero_less_mult_iff pmf_positive)
  also have "  (+t. p t' * indicator {t'} tD)"
    using in_S[OF t'  D]
    by (subst nn_integral_cmult_indicator) (auto simp: ac_simps emeasure_pmf_single)
  also have "  (+t. p t D)"
    by (auto intro!: nn_integral_mono_AE split: split_indicator simp: in_S AE_measure_pmf_iff
      simp del: nn_integral_indicator_singleton)
  also have "  p s"
    using s  S1 D  K s by (auto intro: SUP_upper simp add: p_S1)
  finally show ?case .
qed simp

definition F_sup :: "('s  ennreal)  's  ennreal" where
  "F_sup f = (λsS. if s  S2 then 1 else if s  S1 then SUP DK s. +t. f t measure_pmf D else 0)"

lemma F_sup_cong: "(s. s  S  f s = g s)  F_sup f s = F_sup g s"
  using K_closed[of s]
  by (auto simp: F_sup_def AE_measure_pmf_iff subset_eq
              intro!: SUP_cong nn_integral_cong_AE)

lemma continuous_F_sup: "sup_continuous F_sup"
  unfolding sup_continuous_def fun_eq_iff F_sup_def[abs_def]
  by (auto simp:  SUP_apply[abs_def] nn_integral_monotone_convergence_SUP intro: SUP_commute)

lemma mono_F_sup: "mono F_sup"
  by (intro sup_continuous_mono continuous_F_sup)

lemma lfp_F_sup_iterate: "lfp F_sup = (SUP i. (F_sup ^^ i) (λxS. 0))"
proof -
  { have "(SUP i. (F_sup ^^ i) ) = (SUP i. (F_sup ^^ i) (λxS. 0))"
    proof (rule SUP_eq)
      fix i show "jUNIV. (F_sup ^^ i)   (F_sup ^^ j) (λxS. 0)"
        by (intro bexI[of _ i] funpow_mono mono_F_sup) auto
      have *: "(λxS. 0)  F_sup "
        using K_wf by (auto simp: F_sup_def le_fun_def)
      show "jUNIV. (F_sup ^^ i) (λxS. 0)  (F_sup ^^ j) "
        by (auto intro!: exI[of _ "Suc i"] funpow_mono mono_F_sup  *
                 simp del: funpow.simps simp add: funpow_Suc_right le_funI)
    qed }
  then show ?thesis
    by (auto simp: sup_continuous_lfp continuous_F_sup)
qed

lemma p_eq_lfp_F_sup: "p = lfp F_sup"
proof -
  { fix s assume "s  S" let ?F = "λP. HLD S2 or (HLD S1 aand nxt P)"
    have "P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω)) = (i. P_sup s (λω. (?F ^^ i)  (s ## ω)))"
    proof (simp add: suntil_def, rule P_sup_lfp)
      show "(##) s  measurable St St"
        by simp
      (* This proof should work automatically *)
      fix P assume P: "Measurable.pred St P"
      show "Measurable.pred St (HLD S2 or (HLD S1 aand (λω. P (stl ω))))"
        by (intro pred_intros_logic measurable_compose[OF _ P] measurable_compose[OF measurable_shd]) auto
    qed (auto simp: sup_continuous_def)
    also have " = (SUP i. (F_sup ^^ i) (λxS. 0) s)"
    proof (rule SUP_cong)
      fix i from s  S show "P_sup s (λω. (?F ^^ i)  (s##ω)) = (F_sup ^^ i) (λxS. 0) s"
      proof (induct i arbitrary: s)
        case (Suc n) show ?case
        proof (subst P_sup_iterate)
          (* This proof should work automatically *)
          show "Measurable.pred St (λω. (?F ^^ Suc n)  (s ## ω))"
            apply (intro measurable_compose[OF measurable_Stream[OF measurable_const measurable_ident_sets[OF refl]] measurable_predpow])
            apply simp
            apply (simp add: bot_fun_def[abs_def])
            apply (intro pred_intros_logic measurable_compose[OF measurable_stl]  measurable_compose[OF measurable_shd])
            apply auto
            done
        next
          show "(DK s. + t. P_sup t (λω. (?F ^^ Suc n)  (s ## t ## ω)) measure_pmf D) =
            (F_sup ^^ Suc n) (λxS. 0) s"
            unfolding funpow.simps comp_def
            using S1 S2 s  S
            by (subst F_sup_cong[OF Suc(1)[symmetric]])
               (auto simp add: F_sup_def measure_pmf.emeasure_space_1[simplified] K_wf subset_eq)
        qed
      qed simp
    qed simp
    finally have "lfp F_sup s = P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω))"
      by (simp add: lfp_F_sup_iterate image_comp) }
  moreover have "s. s  S  lfp F_sup s = undefined"
    by (subst lfp_unfold[OF mono_F_sup]) (auto simp add: F_sup_def)
  ultimately show ?thesis
    by (auto simp: p_def)
qed

definition "Se = {sS. p s = 0}"

lemma Se: "Se  S"
  by (auto simp add: Se_def)

lemma v_Se: "cfg  valid_cfg  state cfg  Se  v cfg = 0"
  using p_eq_0_imp[of cfg] by (auto simp: Se_def)

lemma Se_nS2: "Se  S2 = {}"
  by (auto simp: Se_def)

lemma Se_E1: "s  Se  S1  (s, t)  E  t  Se"
  unfolding Se_def using S1
  by (auto simp: p_S1 SUP_eq_iff K_wf nn_integral_0_iff_AE AE_measure_pmf_iff E_def
           intro: set_pmf_closed antisym
           cong: rev_conj_cong)

lemma Se_E2: "s  S1  (t. (s, t)  E  t  Se)  s  Se"
  unfolding Se_def using S1 S1_S2
  by (force simp: p_S1 SUP_eq_iff K_wf nn_integral_0_iff_AE AE_measure_pmf_iff E_def
            cong: rev_conj_cong)

lemma Se_E_iff: "s  S1  s  Se  (t. (s, t)  E  t  Se)"
  using Se_E1[of s] Se_E2[of s] by blast

definition "Sr = S - (Se  S2)"

lemma Sr: "Sr  S"
  by (auto simp: Sr_def)

lemma Sr_S1: "Sr  S1"
  by (auto simp: p_nS12 Sr_def Se_def)

lemma Sr_eq: "Sr = S1 - Se"
  using S1_S2 S1 S2 by (auto simp add: Sr_def Se_def p_nS12)

lemma v_neq_0_imp: "cfg  valid_cfg  v cfg  0  state cfg  Sr  S2"
  using p_eq_0_imp[of cfg] by (auto simp add: Sr_def Se_def valid_cfg_state_in_S)

lemma valid_cfg_action_in_K: "cfg  valid_cfg  action cfg  K (state cfg)"
  by (auto dest!: valid_cfgD)

lemma K_cfg_E: "cfg  valid_cfg  cfg'  K_cfg cfg  (state cfg, state cfg')  E"
  by (auto simp: E_def K_cfg_def valid_cfg_action_in_K)

lemma Sr_directed_towards_S2:
  assumes s: "s  Sr"
  shows "s  directed_towards S2 {(s, t) | s t. s  Sr  (s, t)  E}" (is "s  ?D")
proof -
  { fix cfg assume "s  ?D" "cfg  cfg_on s"
    with s Sr have "state cfg  Sr" "state cfg  ?D" "cfg  valid_cfg"
      by (auto intro: valid_cfgI)
    then have "v cfg = 0"
    proof (coinduction arbitrary: cfg rule: v_eq_0_coinduct)
      case (cont cfg' cfg)
      with v_neq_0_imp[of cfg'] show ?case
        by (auto intro: directed_towards.intros K_cfg_E)
    qed (auto intro: directed_towards.intros) }
  with p_eq_0_iff[of s] s show ?thesis
    unfolding Sr_def Se_def by blast
qed

definition "proper ct  ct  PiE S K  (sSr. v (simple ct s) > 0)"

lemma Sr_nS2: "s  Sr  s  S2"
  by (auto simp: Sr_def)

lemma properD1: "proper ct  ct  PiE S K"
  by (auto simp: proper_def)

lemma proper_eq:
  assumes ct[simp, intro]: "ct  PiE S K"
  shows "proper ct  Sr  directed_towards S2 (SIGMA s:Sr. ct s)"
    (is "_  _  ?D")
proof -
  have *[simp]: "s. s  Sr  s  S" and ct': "ct  Pi S K"
    using ct by (auto simp: Sr_def simp del: ct)
  { fix s t have "s  S  t  ct s  t  S"
      using K_closed[of s] ct' by (auto simp add: subset_eq) }
  note ct_closed = this

  let ?C = "simple ct"
  from ct have valid_C[simp]: "s. s  S  ?C s  valid_cfg"
    by (auto simp add: PiE_def)
  { fix s assume "s  ?D"
    then have "0 < v (?C s)"
    proof induct
      case (step s t)
      then have s: "s  Sr" and t: "t  ct s" and [simp]: "s  S"
        by auto
      with Sr_S1 ct have "v (?C s) = (+t. v (?C t) ct s)"
        by (subst v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
      also have "  0"
        using ct t step
        by (subst nn_integral_0_iff_AE) (auto simp add: AE_measure_pmf_iff zero_less_iff_neq_zero)
      finally show ?case
        using ct by (auto simp add: less_le)
    qed (subst v_S2, insert S2, auto) }
  moreover
  { fix s assume s: "s  ?D" "s  Sr"
    with ct' have C: "?C s  cfg_on s" and [simp]: "s  S"
      by auto
    from s have "v (?C s) = 0"
    proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
      case (cont cfg s)
      with S1 obtain t where "cfg = ?C t" "t  ct s" "s  S"
        by (auto simp: set_K_cfg subset_eq)
      with cont(1,2) v_neq_0_imp[of "?C t"] ct_closed[of s t] show ?case
        by (intro exI[of _ t] disjCI) (auto intro: directed_towards.intros)
    qed (auto simp: Sr_nS2) }
  ultimately show ?thesis
    unfolding proper_def using ct by (force simp del: v_nS v_S2 v_nS12 ct)
qed

lemma exists_proper:
  obtains ct where "proper ct"
proof atomize_elim
  define r where "r = rec_nat S2 (λ_ S'. {sSr. tS'. (s, t)  E})"
  then have [simp]: "r 0 = S2" "n. r (Suc n) = {sSr. tr n. (s, t)  E}"
    by simp_all

  { fix s assume "s  Sr"
    then have "s  directed_towards S2 {(s, t) | s t. s  Sr  (s, t)  E}"
      by (rule Sr_directed_towards_S2)
    from this sSr have "n. s  r n"
    proof induction
      case (step s t)
      show ?case
      proof cases
        assume "t  S2" with step.prems step.hyps show ?thesis
          by (intro exI[of _ "Suc 0"]) force
      next
        assume "t  S2"
        with step obtain n where "t  r n" "t  Sr"
          by (auto elim: directed_towards.cases)
        with tSr step.hyps show ?thesis
          by (intro exI[of _ "Suc n"]) force
      qed
    qed (simp add: Sr_def) }
  note r = this

  { fix s assume "s  S"
    have "DK s. s  Sr  (tD. n. t  r n  (m. s  r m  n < m))"
    proof cases
      assume s: "s  Sr"
      define n where "n = (LEAST n. s  r n)"
      then have "s  r n" and n: "i. i < n  s  r i"
        using r s by (auto intro: LeastI_ex dest: not_less_Least)
      with s have "n  0"
        by (intro notI) (auto simp: Sr_def)
      then obtain n' where "n = Suc n'"
        by (cases n) auto
      with s  r n obtain t D where "D  K s" "t  D" "t  r n'"
        by (auto simp: E_def)
      with n n = Suc n' s show ?thesis
        by (auto intro!: bexI[of _ D] bexI[of _ t] exI[of _ n'] simp: not_less_eq[symmetric])
    qed (insert K_wf sS, auto) }
  then obtain ct where ct: "s. s  S  ct s  K s"
    "s. s  S  s  Sr  tct s. n. t  r n  (m. s  r m  n < m)"
    by metis
  then have *: "restrict ct S  PiE S K"
    by auto

  moreover
  { fix s assume "s  Sr"
    then obtain n where "s  r n"
      by (metis r)
    with s  Sr have "s  directed_towards S2 (SIGMA s : Sr. ct s)"
    proof (induction n arbitrary: s rule: less_induct)
      case (less n s)
      moreover with Sr have "s  S" by auto
      ultimately obtain t m where "t  ct s" "t  r m" "m < n"
        using ct[of s] by (auto simp: E_def)
      with less.IH[of m t] s  Sr show ?case
        by (cases m) (auto intro: directed_towards.intros)
    qed }

  ultimately show "ct. proper ct"
    using Sr S2
    by (auto simp: proper_eq[OF *] subset_eq
             intro!: exI[of _ "restrict ct S"]
             cong: Sigma_cong)
qed

definition "l_desc X ct l s 
    s  directed_towards S2 (SIGMA s : X. {l s}) 
    v (simple ct s)  v (simple ct (l s)) 
    l s  maximal (λs. v (simple ct s)) (ct s)"

lemma exists_l_desc:
  assumes ct: "proper ct"
  shows "lSr  Sr  S2. sSr. l_desc Sr ct l s"
proof -
  have ct_closed: "s t. s  S  t  ct s  t  S"
    using ct K_closed by (auto simp: proper_def PiE_iff)
  have ct_Pi: "ct  Pi S K"
    using ct by (auto simp: proper_def)

  have "finite Sr"
    using S_finite by (auto simp: Sr_def)
  then show ?thesis
  proof (induct rule: finite_induct_select)
    case (select X)
    then obtain l where l: "l  X  X  S2" and desc: "s. s  X  l_desc X ct l s"
      by auto
    obtain x where x: "x  Sr - X"
      using X  Sr by auto
    then have "x  S"
      by (auto simp: Sr_def)

    let ?C = "simple ct"
    let ?v = "λs. v (?C s)" and ?E = "λs. set_pmf (ct s)"
    let ?M = "λs. maximal ?v (?E s)"

    have finite_E[simp]: "s. s  S  finite (?E s)"
      using K_closed ct by (intro finite_subset[OF _ S_finite]) (auto simp: proper_def subset_eq)

    have valid_C[simp]: "s. s  S  ?C s  valid_cfg"
      using ct by (auto simp: proper_def intro!: simple_valid_cfg)

    have E_ne[simp]: "s. ?E s  {}"
        by (rule set_pmf_not_empty)

    have "sSr - X. t?M s. t  S2  X"
    proof (rule ccontr)
      assume "¬ ?thesis"
      then have not_M: "s. s  Sr - X  ?M s  (S2  X) = {}"
        by auto

      let ?Sm = "maximal ?v (Sr - X)"

      have "finite (Sr - X)" "Sr - X  {}"
        using X  Sr by (auto intro!: finite_subset[OF _ S_finite] simp: Sr_def)
      from maximal_ne[OF this] obtain sm where sm: "sm  ?Sm"
        by force

      have "s0?Sm. t?E s0. t  ?Sm"
      proof (rule ccontr)
        assume "¬ ?thesis"
        then have Sm: "s0 t. s0  ?Sm  t  ?E s0  t  ?Sm" by blast
        from sm  ?Sm have [simp]: "sm  S" and "sm  Sr"
          by (auto simp: Sr_def dest: maximalD1)

        from sm  ?Sm have "v (?C sm) = 0"
        proof (coinduction arbitrary: sm rule: v_eq_0_coinduct)
          case (cont t sm) with S1 show ?case
            by (intro exI[of _ "state t"] disjCI conjI Sm[of sm "state t"])
               (auto simp: set_K_cfg)
        qed (auto simp: Sr_def ct_Pi dest!: maximalD1)
        with sm  Sr ‹proper ct show False
          by (auto simp: proper_def)
      qed
      then obtain s0 t where "s0  ?Sm" and t: "t  ?E s0" "t  ?Sm"
        by metis
      with Sr_S1 have s0: "s0  Sr - X" and [simp]: "s0  S" and "s0  S1"
        by (auto simp: Sr_def dest: maximalD1)

      from ‹proper ct s0  S s0 have "?v s0  0"
        by (auto simp add: proper_def)
      then have "0 < ?v s0" by (simp add: zero_less_iff_neq_zero)

      { fix t assume "t  Se  S2  X" "t  ?E s0" and "?v s0  ?v t"
        moreover have "t  Se  ?v t = 0"
          by (simp add: p_eq_0_imp Se_def ct_Pi)
        ultimately have t: "t  S2  X" "t  ?E s0"
          using 0 < ?v s0 by (auto simp: Se_def)

        have "maximal ?v (?E s0  (S2  X))  {}"
          using finite_E t by (intro maximal_ne) auto
        moreover
        { fix x y assume x: "x  S2  X" "x  ?E s0"
            and *: "y?E s0  (S2  X). ?v y  ?v x" and y: "y  ?E s0"
          with S2 s0  S[THEN ct_closed] have [simp]: "x  S" "y  S"
            by auto

          have "?v y  ?v x"
          proof cases
            assume "y  Sr - X"
            then have "?v y  ?v s0"
              using s0  ?Sm by (auto intro: maximalD2)
            also note ?v s0  ?v t
            also have "?v t  ?v x"
              using * t by auto
            finally show ?thesis .
          next
            assume "y  Sr - X" with y * show ?thesis
              by (auto simp: Sr_def v_Se[of "?C y"] ct_Pi)
          qed }
        then have "maximal ?v (?E s0  (S2  X))  maximal ?v (?E s0)"
          by (auto simp: maximal_def)
        moreover note not_M[OF s0]
        ultimately have False
          by (blast dest: maximalD1) }
      then have less_s0: "t. t  Se  S2  X  t  ?E s0  ?v t < ?v s0"
        by (auto simp add: not_le[symmetric])

      let ?K = "ct s0"

      have "?v s0 = (+ x. ?v x ?K)"
        using v_S1[of "?C s0"] s0  S1 s0  S
        by (auto simp add: ct_Pi intro!: nn_integral_cong_AE AE_pmfI)
      also have " < (+x. ?v s0 ?K)"
      proof (intro nn_integral_less)
        have "(+x. ?v x ?K)  (+x. 1 ?K)"
          using ct ct_closed[of s0]
          by (intro nn_integral_mono_AE)
             (auto intro!: v_le_1 simp: AE_measure_pmf_iff proper_def ct_Pi)
        then show "(+x. ?v x ?K)  "
          by (auto simp: top_unique)
        have "?v t < ?v s0"
        proof cases
          assume "t  Se  S2  X" then show ?thesis
            using less_s0[of t] t by simp
        next
          assume "t  Se  S2  X"
          with t(1) ct_closed[of s0 t] have "t  Sr - X"
            unfolding Sr_def by (auto simp: E_def)
          with t(2) show ?thesis
            using s0  ?Sm by (auto simp: maximal_def not_le intro: less_le_trans)
        qed
        then show "¬ (AE x in ?K. ?v s0  ?v x)"
          using t by (auto simp: not_le AE_measure_pmf_iff E_def cong del: AE_cong intro!: exI[of _ "t"])

        show "AE x in ?K. ?v x  ?v s0"
        proof (subst AE_measure_pmf_iff, safe)
          fix t assume t: "t  ?E s0"
          show "?v t  ?v s0"
          proof cases
            assume "t  Se  S2  X" then show ?thesis
              using less_s0[of t] t by simp
          next
            assume "t  Se  S2  X" with t s0  ?Sm s0  S show ?thesis
              by (elim maximalD2) (auto simp: Sr_def intro!: ct_closed[of _ t])
          qed
        qed
      qed (insert ct_closed[of s0], auto simp: AE_measure_pmf_iff)
      also have " = ?v s0"
        using s0  S measure_pmf.emeasure_space_1[of "ct s0"] by simp
      finally show False
        by simp
    qed
    then obtain s t where s: "s  Sr - X" and t: "t  S2  X" "t  ?M s"
      by auto
    with S2 X  Sr have "s  S2" and "s  S  s  S2" and "s  X"and [simp]: "t  S"
      by (auto simp add: Sr_def)
    define l' where "l' = l(s := t)"
    then have l'_s[simp, intro]: "l' s = t"
      by simp

    let ?D = "λX l. directed_towards S2 (SIGMA s : X. {l s})"
    { fix s' assume "s'  ?D X l" "s'  X"
      from this(1) have "s'  ?D (insert s X) l'"
        by (rule directed_towards_mono) (auto simp: l'_def s  X) }
    note directed_towards_l' = this

    show ?case
    proof (intro bexI ballI, elim insertE)
      show "s  Sr - X" by fact
      show "l'  insert s X  insert s X  S2"
        using s t l by (auto simp: l'_def)
    next
      fix s' assume s': "s'  X"
      moreover
      from desc[OF s'] have "s'  ?D X l" and *: "?v s'  ?v (l s')" "l s'  ?M s'"
        by (auto simp: l_desc_def)
      moreover have "l' s' = l s'"
        using s'  X s by (auto simp add: l'_def)
      ultimately show "l_desc (insert s X) ct l' s'"
        by (auto simp: l_desc_def intro!: directed_towards_l')
    next
      fix s' assume "s' = s"
      show "l_desc (insert s X) ct l' s'"
        unfolding s' = s l_desc_def l'_s
      proof (intro conjI)
        show "s  ?D (insert s X) l'"
        proof cases
          assume "t  S2"
          with t have "t  X" by auto
          with desc have "t  ?D X l"
            by (simp add: l_desc_def)
          then show ?thesis
            by (force intro: directed_towards.step[OF directed_towards_l'] t  X)
        qed (force intro: directed_towards.step directed_towards.start)

        from s  Sr - X Sr_S1 have [simp]: "s  S1" "s  S"
          by (auto simp: Sr_def)
        show "?v s  ?v t"
          using t(2)[THEN maximalD2] ct
          by (auto simp add: v_S1 AE_measure_pmf_iff proper_def Pi_iff PiE_def
                   intro!: measure_pmf.nn_integral_le_const)
      qed fact
    qed
  qed simp
qed

lemma F_v_memoryless:
  obtains ct where "ct  PiE S K" "vsimple ct = F_sup (vsimple ct)"
proof atomize_elim
  define R where "R = {(ct(s := D), ct) | ct s D.
    ct  PiE S K  proper ct  s  Sr  D  K s  v (simple ct s) < (+t. v (simple ct t) D) }"

  { fix ct ct' assume ct_ct': "(ct', ct)  R"
    let ?v = "λs. v (simple ct s)" and ?v' = "λs. v (simple ct' s)"

    from ct_ct' obtain s D where "ct  PiE S K" "proper ct" and s: "s  Sr" and D: "D  K s"
      and not_maximal: "?v s < (+t. ?v t D)" and ct'_eq: "ct' = ct(s := D)"
      by (auto simp: R_def)
    with Sr_S1 have ct: "ct  Pi S K" and "s  S" and "s  S1"
      by (auto simp: Sr_def)
    then have valid_ct[simp]: "s. s  S  simple ct s  cfg_on s"
      by simp

    from ct'_eq have [simp]: "ct' s = D" "t. t  s  ct' t = ct t"
      by simp_all

    from ct_ct' Sr have ct'_E: "ct'  PiE S K"
      by (auto simp: ct'_eq R_def)
    from ct s D have ct': "ct'  Pi S K"
      by (auto simp: ct'_eq)
    then have valid_ct'[simp]: "s. s  S  simple ct' s  cfg_on s"
      by simp

    from exists_l_desc[OF ‹proper ct]
    obtain l where l: "l  Sr  Sr  S2" and "s. s  Sr  l_desc Sr ct l s"
      by auto
    then have directed_l: "s. s  Sr  s  directed_towards S2 (SIGMA s:Sr. {l s})"
      and v_l_mono: "s. s  Sr  ?v s  ?v (l s)"
      and l_in_Ea: "s. s  Sr  l s  ct s"
      by (auto simp: l_desc_def dest!: maximalD1)

    let ?E = "λct. SIGMA s:Sr. ct s"
    let ?D = "λct. directed_towards S2 (?E ct)"

    have finite_E[simp]: "s. s  S  finite (ct' s)"
      using ct' K_closed by (intro rev_finite_subset[OF S_finite]) auto

    have "maximal ?v (ct' s)  {}"
      using ct' D sS finite_E[of s] by (intro maximal_ne set_pmf_not_empty) (auto simp del: finite_E)
    then obtain s' where s': "s'  maximal ?v (ct' s)"
      by blast
    with K_closed[OF s  S] D have "s'  S"
      by (auto dest!: maximalD1)

    have "s'  s"
    proof
      assume [simp]: "s' = s"
      have "?v s < (+t. ?v t D)"
        by fact
      also have "  (+t. ?v s D)"
        using s  S s' D by (intro nn_integral_mono_AE) (auto simp: AE_measure_pmf_iff intro: maximalD2)
      finally show False
        using measure_pmf.emeasure_space_1[of D] by (simp add: s  S ct)
    qed

    have "p s'  0"
    proof
      assume "p s' = 0"
      then have "?v s' = 0"
        using v_le_p[of "simple ct s'"] ct s'  S by (auto intro!: antisym ct)
      then have "(+t. ?v t D) = 0"
        using maximalD2[OF s'] by (subst nn_integral_0_iff_AE) (auto simp: sS D AE_measure_pmf_iff)
      then have "?v s < 0"
        using not_maximal by auto
      then show False
        using sS by (simp add: ct)
    qed
    with s'  S have "s'  S2  Sr"
      by (auto simp: Sr_def Se_def)

    have l_acyclic: "(s', s)  (SIGMA s:Sr. {l s})^+"
    proof
      assume "(s', s)  (SIGMA s:Sr. {l s})^+"
      then have "?v s'  ?v s"
        by induct (blast intro: order_trans v_l_mono)+
      also have " < (+t. ?v t D)"
        using not_maximal .
      also have "  (+t. ?v s' D)"
        using s' by (intro nn_integral_mono_AE) (auto simp: s  S D AE_measure_pmf_iff intro: maximalD2)
      finally show False
        using measure_pmf.emeasure_space_1[of D] by (simp add:s'  S ct)
    qed

    from s'  S2  Sr have "s'  ?D ct'"
    proof
      assume "s'  Sr"
      then have "l s'  directed_towards S2 (SIGMA s:Sr. {l s})"
        using l directed_l[of "l s'"] by (auto intro: directed_towards.start)
      moreover from s'  Sr have "(s', l s')  (SIGMA s:Sr. {l s})^+"
        by auto
      ultimately have "l s'  ?D ct'"
      proof induct
        case (step t t')
        then have t: "t  s" "t  Sr" "t' = l t"
          using l_acyclic by auto

        from step have "(s', t')  (SIGMA s:Sr. {l s})+"
          by (blast intro: trancl_into_trancl)
        from step(2)[OF this] show ?case
          by (rule directed_towards.step) (simp add: l_in_Ea t)
      qed (rule directed_towards.start)
      then show "s'  ?D ct'"
        by (rule directed_towards.step)
           (simp add: l_in_Ea s'  Sr s  Sr s'  s)
    qed (rule directed_towards.start)

    have proper: "proper ct'"
      unfolding proper_eq[OF ct'_E]
    proof
      fix t assume "t  Sr"
      from directed_l[OF this] show "t  ?D ct'"
      proof induct
        case (step t t')
        show ?case
        proof cases
          assume "t = s"
          with s  Sr s'[THEN maximalD1] have "(t, s')  ?E ct'"
            by auto
          with s'  ?D ct' show ?thesis
            by (rule directed_towards.step)
        next
          assume "t  s"
          with step have "(t, t')  ?E ct'"
            by (auto simp: l_in_Ea)
          with step.hyps(2) show ?thesis
            by (rule directed_towards.step)
        qed
      qed (rule directed_towards.start)
    qed

    have "?v  ?v'"
    proof (intro le_funI leI notI)
      fix t' assume *: "?v' t' < ?v t'"
      then have "t'  S"
        by (metis v_nS simple_valid_cfg_iff ct' ct order.irrefl)

      define Δ where "Δ t = enn2real (?v t) - enn2real (?v' t)" for t
      with * t'  S have "0 < Δ t'"
        by (cases "?v t'" "?v' t'" rule: ennreal2_cases) (auto simp add: ct' ct ennreal_less_iff)

      { fix t assume t: "t  maximal Δ S"
        with t'  S have "Δ t'  Δ t"
          by (auto intro: maximalD2)
        with 0 < Δ t' have "0 < Δ t" by simp
        with t have "t  Sr"
          by (auto simp add: Sr_def v_Se ct ct' Δ_def dest!: maximalD1) }
      note max_is_Sr = this

      { fix s assume "s  S"
        with v_le_1[of "simple ct' s"] v_le_1[of "simple ct s"]
        have "¦Δ s¦  1"
          by (cases "?v s" "?v' s" rule: ennreal2_cases) (auto simp: Δ_def ct ct') }
      note Δ_le_1[simp] = this
      then have ennreal_Δ: "s. s  S  Δ s = ?v s - ?v' s"
        by (auto simp add: Δ_def v_def T.emeasure_eq_measure ct ct' ennreal_minus)

      from s  S S_finite have "maximal Δ S  {}"
        by (intro maximal_ne) auto
      then obtain t where "t  maximal Δ S" by auto
      from max_is_Sr[OF this] proper have "t  ?D ct'"
        unfolding proper_eq[OF ct'_E] by auto
      from this t  maximal Δ S show False
      proof induct
        case (start t)
        then have "t  Sr"
          by (intro max_is_Sr)
        with t  S2 show False
          by (auto simp: Sr_def)
      next
        case (step t t')
        then have t': "t'  ct' t" and "t  Sr" and t: "t  maximal Δ S"
          by (auto intro: max_is_Sr simp: comp_def)
        then have "t'  S" "t  S1" "t  S"
          using Sr_S1 S1
          by (auto simp: Pi_closed[OF ct'])

        have "Δ t  Δ t'"
        proof (intro leI notI)
          assume less: "Δ t' < Δ t"
          have "(s. Δ s ct' t) < (s. Δ t ct' t)"
          proof (intro measure_pmf.integral_less_AE)
            show "emeasure (ct' t) {t'}  0" "{t'}  sets (ct' t)"
              "AE s in ct' t. s{t'}  Δ s  Δ t"
              using t' less by (auto simp add: emeasure_pmf_single_eq_zero_iff)
            show "AE s in ct' t. Δ s  Δ t"
              using ct' ct t D
              by (auto simp add: AE_measure_pmf_iff ct tS Pi_iff E_def Pi_closed[OF ct']
                       intro!: maximalD2[of t Δ] intro: Pi_closed[OF ct'] maximalD1)
            show "integrable (ct' t) (λ_. Δ t)" "integrable (ct' t) Δ"
              using ct ct' t  S D
              by (auto intro!: measure_pmf.integrable_const_bound[where B=1] Δ_le_1
                       simp: AE_measure_pmf_iff dest: Pi_closed)
          qed
          also have " = Δ t"
            using measure_pmf.prob_space[of "ct' t"] by simp
          also have "Δ t  (s. enn2real (?v s) ct' t) - (s. enn2real (?v' s) ct' t)"
          proof -
            have "?v t  (+s. ?v s ct' t)"
            proof cases
              assume "t = s" with not_maximal show ?thesis by simp
            next
              assume "t  s" with S1 tS1 t  S ct ct' show ?thesis
                by (subst v_S1) (auto intro!: nn_integral_mono_AE AE_pmfI)
            qed
            also have " = ennreal (s. enn2real (?v s) ct' t)"
              using ct ct' tS
              by (intro measure_pmf.ennreal_integral_real[symmetric, where B=1])
                 (auto simp: AE_measure_pmf_iff one_ennreal_def[symmetric]
                       intro!: v_le_1 simple_valid_cfg intro: Pi_closed)
            finally have "enn2real (?v t)  (s. enn2real (?v s) ct' t)"
              using ct tS by (simp add: v_def T.emeasure_eq_measure)
            moreover
            { have "?v' t = (+s. ?v' s ct' t)"
                using ct ct' t  S t  S1 S1 by (subst v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
              also have " = ennreal (s. enn2real (?v' s) ct' t)"
                using ct' tS
                by (intro measure_pmf.ennreal_integral_real[symmetric, where B=1])
                   (auto simp: AE_measure_pmf_iff one_ennreal_def[symmetric]
                         intro!:  v_le_1 simple_valid_cfg intro: Pi_closed)
              finally have "enn2real (?v' t) = (s. enn2real (?v' s) ct' t)"
                using ct' tS by (simp add: v_def T.emeasure_eq_measure) }
            ultimately show ?thesis
              using t  S by (simp add: Δ_def ennreal_minus_mono)
          qed
          also have " = (s. Δ s ct' t)"
            unfolding Δ_def using Pi_closed[OF ct tS] Pi_closed[OF ct' tS] ct ct'
            by (intro Bochner_Integration.integral_diff[symmetric] measure_pmf.integrable_const_bound[where B=1])
               (auto simp: AE_measure_pmf_iff real_v)
          finally show False
            by simp
        qed
        with t[THEN  maximalD2] t  S t'  S have "Δ t = Δ t'"
          by (auto intro: antisym)
        with t t'  S have "t'  maximal Δ S"
          by (auto simp: maximal_def)
        then show ?case
          by fact
      qed
    qed
    moreover have "?v s < ?v' s"
    proof -
      have "?v s < (+t. ?v t D)"
        by fact
      also have "  (+t. ?v' t D)"
        using ?v  ?v' sS D ct ct'
        by (intro nn_integral_mono) (auto simp: le_fun_def)
      also have " = ?v' s"
        using sS1 S1 ct' s  S by (subst (2) v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
      finally show ?thesis .
    qed
    ultimately have "?v < ?v'"
      by (auto simp: less_le le_fun_def fun_eq_iff)
    note this proper ct' }
  note v_strict = this(1) and proper = this(2) and sc'_R = this(3)

  have "finite (PiE S K × PiE S K)"
    by (intro finite_PiE S_finite K_finite finite_SigmaI)
  then have "finite R"
    by (rule rev_finite_subset) (auto simp add: PiE_iff Sr_def R_def intro: extensional_arb)
  moreover
  from v_strict have "acyclic R"
    by (rule acyclicI_order)
  ultimately have "wf R"
    by (rule finite_acyclic_wf)

  from exists_proper obtain ct' where ct': "proper ct'" .
  define ct where "ct = restrict ct' S"
  with ct' have sc_Pi: "ct  Pi S K" and "ct'  Pi S K"
    by (auto simp: proper_def)
  then have ct: "ct  {ct  PiE S K. proper ct}"
    using ct' directed_towards_mono[where F="SIGMA s:Sr. ct' s" and G="SIGMA s:Sr. ct s"]
    apply simp
    apply (subst proper_eq)
    by (auto simp: ct_def proper_eq[OF properD1[OF ct']] subset_eq Sr_def)

  show "ct. ct  PiE S K  vsimple ct = F_sup (vsimple ct)"
  proof (rule wfE_min[OF ‹wf R ct])
    fix ct assume ct: "ct  {ct  PiE S K. proper ct}"
    then have "ct  Pi S K" "proper ct"
      by (auto simp: proper_def)
    assume min: "ct'. (ct', ct)  R  ct'  {ct  PiE S K. proper ct}"
    let ?v = "λs. v (simple ct s)"
    { fix s assume "s  S" "s  S1" "s  S2"
      with ct have "ct s  K s" "?v s  integralN (ct s) ?v"
        by (auto simp: v_S1 PiE_def intro!: nn_integral_mono_AE AE_pmfI)
      moreover
      { have "0  ?v s"
          using sS ct by (simp add: PiE_def)
        also assume v_less: "?v s < (DK s. + s. v (simple ct s) measure_pmf D)"
        also have "  p s"
          unfolding p_S1[OF sS1] using sS ct v_le_p[OF simple_valid_cfg, OF ct  Pi S K]
          by (auto intro!: SUP_mono nn_integral_mono_AE bexI
                   simp: PiE_def AE_measure_pmf_iff set_pmf_closed)
        finally have "s  Sr"
          using sS sS2 by (simp add: Sr_def Se_def)

        from v_less obtain D where "D  K s" "?v s < integralN D ?v"
          by (auto simp: less_SUP_iff)
        with ct sS sSr have "(ct(s:=D), ct)  R" "ct(s:=D)  PiE S K"
          unfolding R_def by (auto simp: PiE_def extensional_def)
        from proper[OF this(1)] min[OF this(1)] ct D  K s sS this(2)
        have False
          by simp }
      ultimately have "?v s = (DK s. + s. ?v s measure_pmf D)"
        by (auto intro: antisym SUP_upper2[where i="ct s"] leI)
      also have " = (DK s. integralN (measure_pmf D) (λsS. ?v s))"
        using sS by (auto intro!: SUP_cong nn_integral_cong v_nS simp: ct simple_valid_cfg_iff ct  Pi S K)
      finally have "?v s = (DK s. integralN (measure_pmf D) (λsS. ?v s))" . }
    then have "?v = F_sup ?v"
      unfolding F_sup_def using ct
      by (auto intro!: ext v_S2 simple_cfg_on v_nS v_nS12 SUP_cong nn_integral_cong
               simp: PiE_def simple_valid_cfg_iff)
    with ct show ?thesis
      by (auto simp: comp_def)
  qed
qed

lemma p_v_memoryless:
  obtains ct where "ct  PiE S K" "p = vsimple ct"
proof -
  obtain ct where ct_PiE: "ct  PiE S K" and eq: "vsimple ct = F_sup (vsimple ct)"
    by (rule F_v_memoryless)
  then have ct: "ct  Pi S K"
    by (simp add: PiE_def)
  have "p = vsimple ct"
  proof (rule antisym)
    show "p  vsimple ct"
      unfolding p_eq_lfp_F_sup by (rule lfp_lowerbound) (metis order_refl eq)
    show "vsimple ct  p"
    proof (rule le_funI)
      fix s show "(vsimple ct) s  p s"
        using v_le_p[of "simple ct s"]
        by (cases "s  S") (auto simp del: simp add: v_def ct)
    qed
  qed
  with ct_PiE that show thesis by auto
qed

definition "n = (λsS. P_inf s (λω. (HLD S1 suntil HLD S2) (s ## ω)))"

lemma n_eq_INF_v: "s  S  n s = (cfgcfg_on s. v cfg)"
  by (auto simp add: n_def v_def P_inf_def T.emeasure_eq_measure valid_cfgI intro!: INF_cong)

lemma n_le_v: "s  S  cfg  cfg_on s  n s  v cfg"
  by (subst n_eq_INF_v) (blast intro!: INF_lower)+

lemma n_eq_1_imp: "s  S  cfg  cfg_on s  n s = 1  v cfg = 1"
  using n_le_v[of s cfg] v_le_1[of cfg] by (auto intro: antisym valid_cfgI)

lemma n_eq_1_iff: "s  S  n s = 1  (cfgcfg_on s. v cfg = 1)"
  apply rule
  apply (metis n_eq_1_imp)
  apply (auto simp: n_eq_INF_v intro!: INF_eqI)
  done

lemma n_le_1: "s  S  n s  1"
  by (auto simp: n_eq_INF_v intro!: INF_lower2[OF simple_cfg_on[of arb_act]] v_le_1)

lemma n_undefined[simp]: "s  S  n s = undefined"
  by (simp add: n_def)

lemma n_eq_0: "s  S  cfg  cfg_on s  v cfg = 0  n s = 0"
  using n_le_v[of s cfg] by auto

lemma n_not_inf[simp]: "s  S  n s  top"
  using n_le_1[of s] by (auto simp: top_unique)

lemma n_S1: "s  S1  n s = (DK s. + t. n t measure_pmf D)"
  using S1 S1_S2 unfolding n_def
  apply auto
  apply (subst P_inf_iterate)
  apply (auto intro!: nn_integral_cong_AE INF_cong intro: set_pmf_closed
              simp: AE_measure_pmf_iff suntil_Stream set_eq_iff)
  done

lemma n_S2[simp]: "s  S2  n s = 1"
  using S2 by (auto simp add: n_eq_INF_v valid_cfgI)

lemma n_nS12: "s  S  s  S1  s  S2  n s = 0"
  by (auto simp add: n_eq_INF_v valid_cfgI)

lemma n_pos:
  assumes "P s" "s  S1" "wf R"
  assumes cont: "s D. P s  s  S1  D  K s  wD. ((w, s)  R  w  S1  P w)  0 < n w"
  shows "0 < n s"
  using ‹wf R P s sS1
proof (induction s)
  case (less s)
  with S1 have [simp]: "s  S" by auto
  let ?I = "λD::'s pmf. +t. n t D"
  have "0 < Min (?I`K s)"
  proof (safe intro!: Min_gr_iff [THEN iffD2])
    fix D assume [simp]: "D  K s"
    from cont[OF P s s  S1 D  K s]
    obtain w where w: "w  D" "0 < n w"
      by (force intro: less.IH)
    have in_S: "t. t  D  t  S"
      using set_pmf_closed[OF s  S D  K s] by auto
    from w have "0 < pmf D w * n w"
      by (simp add: pmf_positive ennreal_zero_less_mult_iff)
    also have " = (+t. n w * indicator {w} t D)"
      by (subst nn_integral_cmult_indicator)
         (auto simp: ac_simps emeasure_pmf_single in_S w  D)
    also have "  (+t. n t D)"
      by (intro nn_integral_mono_AE) (auto split: split_indicator simp: AE_measure_pmf_iff in_S)
    finally show "0 < (+t. n t D)" .
  qed (insert K_wf K_finite sS, auto)
  also have " = n s"
    unfolding n_S1[OF s  S1]
    using K_wf K_finite sS by (intro Min_Inf) auto
  finally show "0 < n s" .
qed

definition F_inf :: "('s  ennreal)  ('s  ennreal)" where
  "F_inf f = (λsS. if s  S2 then 1 else if s  S1 then (DK s. + t. f t measure_pmf D) else 0)"

lemma F_inf_n: "F_inf n = n"
  by (simp add: F_inf_def n_nS12 n_S1 fun_eq_iff)

lemma F_inf_nS[simp]: "s  S  F_inf f s = undefined"
  by (simp add: F_inf_def)

lemma mono_F_inf: "mono F_inf"
  by (auto intro!: INF_superset_mono nn_integral_mono simp: mono_def F_inf_def le_fun_def)

lemma S1_nS2: "s  S1  s  S2"
  using S1_S2 by auto

lemma n_eq_lfp_F_inf: "n = lfp F_inf"
proof (intro antisym lfp_lowerbound le_funI)
  fix s let ?I = "λD. (+t. lfp F_inf t measure_pmf D)"
  define ct where "ct s = (SOME D. D  K s  (s  S1  lfp F_inf s = ?I D))" for s
  { fix s assume s: "s  S"
    then have "finite (?I ` K s)"
      by (auto intro: K_finite)
    with s obtain D where "D  K s" "(+t. lfp F_inf t D) = Min (?I ` K s)"
      by (auto simp: K_wf dest!: Min_in)
    note this(2)
    also have " = (INF D  K s. ?I D)"
      using s K_wf by (subst Min_Inf) (auto intro: K_finite)
    also have "s  S1   = lfp F_inf s"
      using s S1_S2 by (subst (3) lfp_unfold[OF mono_F_inf]) (auto simp add: F_inf_def)
    finally have "D. D  K s  (s  S1  lfp F_inf s = ?I D)"
      using D  K s by auto
    then have "ct s  K s  (s  S1  lfp F_inf s = ?I (ct s))"
      unfolding ct_def by (rule someI_ex)
    then have "ct s  K s" "s  S1  lfp F_inf s = ?I (ct s)"
      by auto }
  note ct = this
  then have Pi_ct: "ct  Pi S K"
    by auto
  then have valid_ct[simp]: "s. s  S  simple ct s  valid_cfg"
    by simp
  let ?F = "λP. HLD S2 or (HLD S1 aand nxt P)"
  define P where "P s n =
      emeasure (T (simple ct s)) {xspace (T (simple ct s)). (?F ^^ n) (λx. False) (s ## x)}"
    for s n
  { assume "s  S"
    with S1 have [simp, measurable]: "s  S" by auto
    then have "n s  v (simple ct s)"
      by (intro n_le_v) (auto intro: simple_cfg_on[OF Pi_ct])
    also have " = emeasure (T (simple ct s)) {xspace (T (simple ct s)). lfp ?F (s ## x)}"
      using S1_S2
      by (simp add: v_eq[OF simple_valid_cfg[OF Pi_ct sS]])
         (simp add: suntil_lfp space_T[symmetric, of "simple ct s"] del: space_T)
    also have " = (n. P s n)" unfolding P_def
      apply (rule emeasure_lfp2[where P="λM. s. M = T (simple ct s)" and M="T (simple ct s)"])
      apply (intro exI[of _ s] refl)
      apply (auto simp: sup_continuous_def) []
      apply auto []
    proof safe
      fix A s assume "N. s. N = T (simple ct s)  Measurable.pred N A"
      then have "s. Measurable.pred (T (simple ct s)) A"
        by metis
      then have "s. Measurable.pred St A"
        by simp
      then show "Measurable.pred (T (simple ct s)) (λxs. HLD S2 xs  HLD S1 xs  nxt A xs)"
        by simp
    qed
    also have "  lfp F_inf s"
    proof (intro SUP_least)
      fix n from sS show "P s n  lfp F_inf s"
      proof (induct n arbitrary: s)
        case 0 with S1 show ?case
          by (subst lfp_unfold[OF mono_F_inf]) (auto simp: P_def)
      next
        case (Suc n)

        show ?case
        proof cases
          assume "s  S1" with S1_S2 S1 have s[simp]: "s  S2" "s  S" "s  S1" by auto
          have "P s (Suc n) = (+t. P t n ct s)"
            unfolding P_def space_T
            apply (subst emeasure_Collect_T)
            apply (rule measurable_compose[OF measurable_Stream[OF measurable_const measurable_ident_sets[OF refl]]])
            apply (measurable, assumption)
            apply (auto simp: K_cfg_def map_pmf_rep_eq nn_integral_distr
                        intro!: nn_integral_cong_AE AE_pmfI)
            done
          also have "  (+t. lfp F_inf t ct s)"
            using Pi_closed[OF Pi_ct s  S]
            by (auto intro!: nn_integral_mono_AE Suc simp: AE_measure_pmf_iff)
          also have " = lfp F_inf s"
            by (intro ct(2)[symmetric]) auto
          finally show ?thesis .
        next
          assume "s  S1" with S2 s  S show ?case
            using T.emeasure_space_1[of "simple ct s"]
            by (subst lfp_unfold[OF mono_F_inf]) (auto simp: F_inf_def P_def)
        qed
      qed
    qed
    finally have "n s  lfp F_inf s" . }
  moreover have "s  S  n s  lfp F_inf s"
    by (subst lfp_unfold[OF mono_F_inf]) (simp add: n_def F_inf_def)
  ultimately show "n s  lfp F_inf s"
    by blast
qed (simp add: F_inf_n)


lemma real_n: "s  S  ennreal (enn2real (n s)) = n s"
  by (cases "n s") simp_all

lemma real_p: "s  S  ennreal (enn2real (p s)) = p s"
  by (cases "p s") simp_all

lemma p_ub:
  fixes x
  assumes "s  S"
  assumes solution: "s D. s  S1  D  K s  (tS. pmf D t * x t)  x s"
  assumes solution_0: "s. s  S  p s = 0  x s = 0"
  assumes solution_S2: "s. s  S2  x s = 1"
  shows "enn2real (p s)  x s" (is "?y s  _")
proof -
  let ?p = "λs. enn2real (p s)"
  from p_v_memoryless obtain sc where "sc  PiE S K" and p_eq: "p = v  simple sc"
    by auto
  then have sch: "s. s  S  sc s  K s" and sc_Pi: "sc  Pi S K"
    by (auto simp: PiE_iff)

  interpret sc: MC_syntax sc .

  define N where "N = {sS. p s = 0}  S2"
  { fix s assume "s  S" "s  N"
    with p_nS12 have "s  S1"
      by (auto simp add: N_def) }
  note N = this

  have N_S: "N  S"
    using S2 by (auto simp: N_def)

  have finite_sc[intro]: "s  S  finite (sc s)" for s
    using sc  PiE S K by (auto simp: PiE_iff intro: set_pmf_finite)


  show ?thesis
  proof cases
    assume "s  S - N"
    then show ?thesis
    proof (rule mono_les)
      show "(xS - N. set_pmf (sc x))  S - N  N"
        using Pi_closed[OF sc_Pi] by auto
      show "finite ((λs. ?p s - x s) ` (S - N  N))"
        using N_S by (intro finite_imageI finite_subset[OF _ S_finite]) auto
    next
      fix s assume "s  N" then show "?p s  x s"
        by (auto simp: N_def solution_S2 solution_0)
    next
      fix s assume s: "s  S - N"
      then show "integrable (sc s) x" "integrable (sc s) ?p"
        by (auto intro!: integrable_measure_pmf_finite set_pmf_finite sch)

      from s have "s  S1" "s  S"
        using p_nS12[of s] by (auto simp: N_def)
      then show "?p s  ( t. ?p t sc s) + 0"
        unfolding p_eq using real_v_integral_eq[of "simple sc s"]
        by (auto simp add: v_S1 sc_Pi intro!: integral_mono_AE integrable_measure_pmf_finite AE_pmfI)
      show "( t. x t sc s) + 0  x s"
        using solution[OF s  S1 sch[OF s  S]]
        by (subst integral_measure_pmf[where A=S])
           (auto intro: S_finite Pi_closed[OF sc_Pi] s  S simp: ac_simps)

      define X where "X = (SIGMA x:UNIV. sc x)"
      show "tN. (s, t)  X*"
      proof (rule ccontr)
        assume "¬ ?thesis"
        then have *: "tN. (s, t)  X*"
          by auto
        with sS have "v (simple sc s) = 0"
        proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
          case (valid t) with sch show ?case
            by auto
        next
          case (nS2 s) then show ?case
            by (auto simp: N_def)
        next
          case (cont cfg s)
          then have "(s, state cfg)  X*"
            by (auto simp: X_def set_K_cfg)
          with cont show ?case
            by (auto simp: set_K_cfg intro!: exI intro: Pi_closed[OF sc_Pi])
               (blast intro: rtrancl_trans)
        qed
        then have "p s = 0"
          unfolding p_eq by simp
        with sS have "sN"
          by (auto simp: N_def)
        with * show False
          by auto
      qed
    qed
  next
    assume "s  S - N" with s  S show "?p s  x s"
      by (auto simp: N_def solution_0 solution_S2)
  qed
qed

lemma n_lb:
  fixes x
  assumes "s  S"
  assumes solution: "s D. s  S1  D  K s  x s  (tS. pmf D t * x t)"
  assumes solution_n0: "s. s  S  n s = 0  x s = 0"
  assumes solution_S2: "s. s  S2  x s = 1"
  shows "x s  enn2real (n s)" (is "_  ?y s")
proof -
  let ?I = "λD::'s pmf. +x. n x D"
  { fix s assume "s  S1"
    with S1 S1_S2 have "n s = (DK s. ?I D)"
      by (subst n_eq_lfp_F_inf, subst lfp_unfold[OF mono_F_inf])
         (auto simp add: F_inf_def n_eq_lfp_F_inf)
    moreover have "(DK s. +x. n x measure_pmf D) = Min (?I`K s)"
      using s  S1 S1 K_wf
      by (intro cInf_eq_Min finite_imageI K_finite) auto
    moreover have "Min (?I`K s)  ?I`K s"
      using s  S1 S1 K_wf by (intro Min_in finite_imageI K_finite) auto
    ultimately have "DK s. (+x. n x D) = n s"
      by auto }
  then have "s. s  S  DK s. s  S1  (+x. n x D) = n s"
    using K_wf by auto
  then obtain sc where sch: "s. s  S  sc s  K s"
    and n_sc: "s. s  S1  (+x. n x sc s) = n s"
    by (metis S1 subsetD)
  then have sc_Pi: "sc  Pi S K"
    by auto

  define N where "N = {sS. n s = 0}  S2"
  with S2 have N_S: "N  S"
    by auto
  { fix s assume "s  S" "s  N"
    with n_nS12 have "s  S1"
      by (auto simp add: N_def) }
  note N = this

  let ?n = "λs. enn2real (n s)"
  show ?thesis
  proof cases
    assume "s  S - N"
    then show ?thesis
    proof (rule mono_les)
      show "(xS - N. set_pmf (sc x))  S - N  N"
        using Pi_closed[OF sc_Pi] by auto
      show "finite ((λs. x s - ?n s) ` (S - N  N))"
        using N_S by (intro finite_imageI finite_subset[OF _ S_finite]) auto
    next
      fix s assume "s  N" then show "x s  ?n s"
        by (auto simp: N_def solution_S2 solution_n0)
    next
      fix s assume s: "s  S - N"
      then show "integrable (sc s) x" "integrable (sc s) ?n"
        by (auto intro!: integrable_measure_pmf_finite set_pmf_finite sch)

      from s have "s  S1" "s  S"
        using n_nS12[of s] by (auto simp: N_def)
      then have "( t. ?n t sc s) = ?n s"
        apply (subst n_sc[symmetric, of s])
        apply simp_all
        apply (subst integral_eq_nn_integral)
        apply (auto simp: Pi_closed[OF sc_Pi] AE_measure_pmf_iff
                    intro!: arg_cong[where f=enn2real] nn_integral_cong_AE real_n)
        done
      then show "( t. ?n t sc s) + 0  ?n s"
        by simp

      show "x s  ( t. x t sc s) + 0"
        using solution[OF s  S1 sch[OF s  S]]
        by (subst integral_measure_pmf[where A=S])
           (auto intro: S_finite Pi_closed[OF sc_Pi] s  S simp: ac_simps)

      define X where "X = (SIGMA x:UNIV. sc x)"
      show "tN. (s, t)  X*"
      proof (rule ccontr)
        assume "¬ ?thesis"
        then have *: "tN. (s, t)  X*"
          by auto
        with sS have "v (simple sc s) = 0"
        proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
          case (valid t) with sch show ?case
            by auto
        next
          case (nS2 s) then show ?case
            by (auto simp: N_def)
        next
          case (cont cfg s)
          then have "(s, state cfg)  X*"
            by (auto simp: X_def set_K_cfg)
          with cont show ?case
            by (auto simp: set_K_cfg intro!: exI intro: Pi_closed[OF sc_Pi])
               (blast intro: rtrancl_trans)
        qed
        from n_eq_0[OF s  S simple_cfg_on this] have "n s = 0"
          by (auto simp: sc_Pi)
        with sS have "sN"
          by (auto simp: N_def)
        with * show False
          by auto
      qed
    qed
  next
    assume "s  S - N" with s  S show "x s  ?n s"
      by (auto simp: N_def solution_n0 solution_S2)
  qed
qed

end

end

Theory Discrete_Time_Markov_Process

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Discrete-time Markov Processes›

text ‹In this file we construct discrete-time Markov processes, e.g. with arbitrary state spaces.›

theory Discrete_Time_Markov_Process
  imports Markov_Models_Auxiliary
begin

lemma measure_eqI_PiM_sequence:
  fixes M :: "nat  'a measure"
  assumes *[simp]: "sets P = PiM UNIV M" "sets Q = PiM UNIV M"
  assumes eq: "A n. (i. A i  sets (M i)) 
    P (prod_emb UNIV M {..n} (PiE {..n} A)) = Q (prod_emb UNIV M {..n} (PiE {..n} A))"
  assumes A: "finite_measure P"
  shows "P = Q"
proof (rule measure_eqI_PiM_infinite[OF * _ A])
  fix J :: "nat set" and F'
  assume J: "finite J" "i. i  J  F' i  sets (M i)"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i  J then F' i else space (M i))" for i
  then have F[simp, measurable]: "F i  sets (M i)" for i
    using J by auto
  have emb_eq: "prod_emb UNIV M J (PiE J F') = prod_emb UNIV M {..n} (PiE {..n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J  {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le ‹finite J split: if_split_asm)
  qed

  show "emeasure P (prod_emb UNIV M J (PiE J F')) = emeasure Q (prod_emb UNIV M J (PiE J F'))"
    unfolding emb_eq by (rule eq) fact
qed

lemma distr_cong_simp:
  "M = K  sets N = sets L  (x. x  space M =simp=> f x = g x)  distr M N f = distr K L g"
  unfolding simp_implies_def by (rule distr_cong)

subsection ‹Constructing Discrete-Time Markov Processes›

locale discrete_Markov_process =
  fixes M :: "'a measure" and K :: "'a  'a measure"
  assumes K[measurable]: "K  M M prob_algebra M"
begin

lemma space_K: "x  space M  space (K x) = space M"
  using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma sets_K[measurable_cong]: "x  space M  sets (K x) = sets M"
  using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma prob_space_K: "x  space M  prob_space (K x)"
  using measurable_space[OF K] by (simp add: space_prob_algebra)

definition K' :: "'a  nat  (nat  'a)  'a measure"
where
  "K' x n' ω' = K (case_nat x ω' n')"

lemma IT_K':
  assumes x: "x  space M" shows "Ionescu_Tulcea (K' x) (λ_. M)"
  unfolding Ionescu_Tulcea_def K'_def[abs_def]
proof safe
  fix i show "(λω'. K (case i of 0  x | Suc x  ω' x))  PiM {0..<i} (λ_. M) M subprob_algebra M"
    using x by (intro measurable_prob_algebraD measurable_compose[OF _ K]) measurable
next
  fix i :: nat and ω assume ω: "ω  space (PiM {0..<i} (λ_. M))"
  with x have "(case i of 0  x | Suc x  ω x)  space M"
    by (auto simp: space_PiM split: nat.split)
  then show "prob_space (K (case i of 0  x | Suc x  ω x))"
    using K unfolding measurable_restrict_space2_iff prob_algebra_def by auto
qed

definition lim_sequence :: "'a  (nat  'a) measure"
where
  "lim_sequence x = projective_family.lim UNIV (Ionescu_Tulcea.CI (K' x) (λ_. M)) (λ_. M)"

lemma
  assumes x: "x  space M"
  shows space_lim_sequence: "space (lim_sequence x) = space (ΠM iUNIV. M)"
    and sets_lim_sequence[measurable_cong]: "sets (lim_sequence x) = sets (ΠM iUNIV. M)"
    and emeasure_lim_sequence_emb: "J X. finite J  X  sets (ΠM jJ. M) 
      emeasure (lim_sequence x) (prod_emb UNIV (λ_. M) J X) =
      emeasure (Ionescu_Tulcea.CI (K' x) (λ_. M) J) X"
    and emeasure_lim_sequence_emb_I0o: "n X. X  sets (ΠM i  {0..<n}. M) 
      emeasure (lim_sequence x) (prod_emb UNIV (λ_. M) {0..<n} X) =
      emeasure (Ionescu_Tulcea.C (K' x) (λ_. M) 0 n (λx. undefined)) X"
proof -
  interpret Ionescu_Tulcea "K' x" "λ_. M"
    using x by (rule IT_K')
  show "space (lim_sequence x) = space (ΠM iUNIV. M)"
    unfolding lim_sequence_def by simp
  show "sets (lim_sequence x) = sets (ΠM iUNIV. M)"
    unfolding lim_sequence_def by simp

  { fix J :: "nat set" and X assume "finite J" "X  sets (ΠM jJ. M)"
    then show "emeasure (lim_sequence x) (PF.emb UNIV J X) = emeasure (CI J) X"
      unfolding lim_sequence_def by (rule lim) }
  note emb = this

  have up_to_I0o[simp]: "up_to {0..<n} = n" for n
    unfolding up_to_def by (rule Least_equality) auto

  { fix n :: nat and X assume "X  sets (ΠM j{0..<n}. M)"
    then show "emeasure (lim_sequence x) (PF.emb UNIV {0..<n} X) = emeasure (C 0 n (λx. undefined)) X"
      by (simp add: space_C emb CI_def space_PiM distr_id2 sets_C cong: distr_cong_simp) }
qed

lemma lim_sequence[measurable]: "lim_sequence  M M prob_algebra (ΠM iUNIV. M)"
proof (intro measurable_prob_algebra_generated[OF sets_PiM Int_stable_prod_algebra prod_algebra_sets_into_space])
  fix a assume [simp]: "a  space M"
  interpret Ionescu_Tulcea "K' a" "λ_. M"
    by (rule IT_K') simp
  have sp: "space (lim_sequence a) = prod_emb UNIV (λ_. M) {} (ΠE j{}. space M)" "space (CI {}) = {} E space M"
    by (auto simp: space_lim_sequence space_PiM prod_emb_def PF.space_P)
  show "prob_space (lim_sequence a)"
    apply standard
    using PF.prob_space_P[THEN prob_space.emeasure_space_1, of "{}"]
    apply (simp add: sp emeasure_lim_sequence_emb del: PiE_empty_domain)
    done
  show "sets (lim_sequence a) = sets (PiM UNIV (λi. M))"
    by (simp add: sets_lim_sequence)
next
  fix X :: "(nat  'a) set" assume "X  prod_algebra UNIV (λi. M)"
  then obtain J :: "nat set" and F where J: "J  {}" "finite J" "F  J  sets M"
    and X: "X = prod_emb UNIV (λ_. M) J (PiE J F)"
    unfolding prod_algebra_def by auto
  then have Pi_F: "finite J" "PiE J F  sets (PiM J (λ_. M))"
    by (auto intro: sets_PiM_I_finite)

  define n where "n = (LEAST n. in. i  J)"
  have J_le_n: "J  {0..<n}"
    unfolding n_def
    using ‹finite J
    apply -
    apply (rule LeastI2[of _ "Suc (Max J)"])
    apply (auto simp: Suc_le_eq not_le[symmetric])
    done

  have C: "(λx. Ionescu_Tulcea.C (K' x) (λ_. M) 0 n (λx. undefined))  M M subprob_algebra (PiM {0..<n} (λ_. M))"
    apply (induction n)
    apply (subst measurable_cong)
    apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
    apply assumption
    apply (rule measurable_compose[OF _ return_measurable])
    apply simp
    apply (subst measurable_cong)
    apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
    apply assumption
    apply (rule measurable_bind')
    apply assumption
    apply (subst measurable_cong)
  proof -
    fix n :: nat and w assume "w  space (M M PiM {0..<n} (λ_. M))"
    then show "(case w of (x, xa)  Ionescu_Tulcea.eP (K' x) (λ_. M) (0 + n) xa) =
      (case w of (x, xa)  distr (K' x n xa) (ΠM i{0..<Suc n}. M) (fun_upd xa n))"
      by (auto simp: space_pair_measure Ionescu_Tulcea.eP_def[OF IT_K'] split: prod.split)
  next
    fix n show "(λw. case w of (x, xa)  distr (K' x n xa) (PiM {0..<Suc n} (λi. M)) (fun_upd xa n))
          M M PiM {0..<n} (λ_. M) M subprob_algebra (PiM {0..<Suc n} (λ_. M))"
      unfolding K'_def
      apply measurable
      apply (rule measurable_distr2[where M=M])
      apply (rule measurable_PiM_single')
      apply (simp add: split_beta')
      subgoal for i by (cases "i = n") auto
      subgoal by (auto simp: split_beta' PiE_iff extensional_def Pi_iff space_pair_measure space_PiM)
      apply (rule measurable_prob_algebraD)
      apply (rule measurable_compose[OF _ K])
      apply measurable
      done
  qed

  have "(λa. emeasure (lim_sequence a) X)  borel_measurable M 
    (λa. emeasure (Ionescu_Tulcea.CI (K' a) (λ_. M) J) (PiE J F))  borel_measurable M"
    unfolding X using J Pi_F by (intro measurable_cong emeasure_lim_sequence_emb) auto
  also have ""
    apply (intro measurable_compose[OF _ measurable_emeasure_subprob_algebra[OF Pi_F(2)]])
    apply (subst measurable_cong)
    apply (subst Ionescu_Tulcea.CI_def[OF IT_K'])
    apply assumption
    apply (subst Ionescu_Tulcea.up_to_def[OF IT_K'])
    apply assumption
    unfolding n_def[symmetric]
    apply (rule refl)
    apply (rule measurable_compose[OF _ measurable_distr[OF measurable_restrict_subset[OF J_le_n]]])
    apply (rule C)
    done
  finally show "(λa. emeasure (lim_sequence a) X)  borel_measurable M" .
qed

lemma step_C:
  assumes x: "x  space M"
  shows "Ionescu_Tulcea.C (K' x) (λ_. M) 0 1 (λ_. undefined)  Ionescu_Tulcea.C (K' x) (λ_. M) 1 n =
    K x  (λy. Ionescu_Tulcea.C (K' x) (λ_. M) 1 n (case_nat y (λ_. undefined)))"
proof -
  interpret Ionescu_Tulcea "K' x" "λ_. M"
    using x by (rule IT_K')

  have [simp]: "space (K x)  {}"
    using space_K[OF x] x by auto

  have [simp]: "((λ_. undefined::'a)(0 := x)) = case_nat x (λ_. undefined)" for x
    by (auto simp: fun_eq_iff split: nat.split)

  have "C 0 1 (λ_. undefined)  C 1 n = eP 0 (λ_. undefined)  C 1 n"
    using measurable_eP[of 0] measurable_C[of 1 n, measurable del]
    by (simp add: bind_return[where N="PiM {0} (λ_. M)"])
  also have " = K x  (λy. C 1 n (case_nat y (λ_. undefined)))"
    using measurable_C[of 1 n, measurable del] x[THEN sets_K]
    by (simp add: eP_def K'_def bind_distr cong: measurable_cong_sets)
  finally show "C 0 1 (λ_. undefined)  C 1 n = K x  (λy. C 1 n (case_nat y (λ_. undefined)))" .
qed

lemma lim_sequence_eq:
  assumes x: "x  space M"
  shows "lim_sequence x = bind (K x) (λy. distr (lim_sequence y) (ΠM jUNIV. M) (case_nat y))"
    (is "_ = ?B x")
proof (rule measure_eqI_PiM_infinite)
  show "sets (lim_sequence x) = sets (ΠM jUNIV. M)"
    using x by (rule sets_lim_sequence)
  have [simp]: "space (K x)  {}"
    using space_K[OF x] x by auto
  show "sets (?B x) = sets (PiM UNIV (λj. M))"
    using x by (subst sets_bind) auto
  interpret lim_sequence: prob_space "lim_sequence x"
    using lim_sequence x by (auto simp: measurable_restrict_space2_iff prob_algebra_def)
  show "finite_measure (lim_sequence x)"
    by (rule lim_sequence.finite_measure)

  interpret Ionescu_Tulcea "K' x" "λ_. M"
    using x by (rule IT_K')

  let ?U = "λ_::nat. undefined :: 'a"

  fix J :: "nat set" and F'
  assume J: "finite J" "i. i  J  F' i  sets M"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i  J then F' i else space M)" for i
  then have F[simp, measurable]: "F i  sets M" for i
    using J by auto
  have emb_eq: "PF.emb UNIV J (PiE J F') = PF.emb UNIV {0..<Suc n} (PiE {0..<Suc n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J  {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le ‹finite J split: if_split_asm)
  qed

  have "emeasure (lim_sequence x) (PF.emb UNIV J (PiE J F')) = emeasure (C 0 (Suc n) ?U) (PiE {0..<Suc n} F)"
    using x unfolding emb_eq by (rule emeasure_lim_sequence_emb_I0o) (auto intro!: sets_PiM_I_finite)
  also have "C 0 (Suc n) ?U = K x  (λy. C 1 n (case_nat y ?U))"
    using split_C[of ?U 0 "Suc 0" n] step_C[OF x] by simp
  also have "emeasure (K x  (λy. C 1 n (case_nat y ?U))) (PiE {0..<Suc n} F) =
    (+y. C 1 n (case_nat y ?U) (PiE {0..<Suc n} F) K x)"
    using measurable_C[of 1 n, measurable del] x[THEN sets_K] F x
    by (intro emeasure_bind[OF  _ measurable_compose[OF _ measurable_C]])
       (auto cong: measurable_cong_sets intro!: measurable_PiM_single' split: nat.split_asm)
  also have " = (+y. distr (lim_sequence y) (PiM UNIV (λj. M)) (case_nat y) (PF.emb UNIV J (PiE J F')) K x)"
  proof (intro nn_integral_cong)
    fix y assume "y  space (K x)"
    then have y: "y  space M"
      using x by (simp add: space_K)
    then interpret y: Ionescu_Tulcea "K' y" "λ_. M"
      by (rule IT_K')

    let ?y = "case_nat y"
    have [simp]: "?y ?U  space (PiM {0} (λi. M))"
      using y by (auto simp: space_PiM PiE_iff extensional_def split: nat.split)
    have yM[measurable]: "?y  PiM {0..<m} (λ_. M) M PiM {0..<Suc m} (λi. M)" for m
      using y by (intro measurable_PiM_single') (auto simp: space_PiM PiE_iff extensional_def split: nat.split)

    have y': "?y ?U  space (PiM {0..<1} (λi. M))"
      by (simp add: space_PiM PiE_def y extensional_def split: nat.split)

    have eq1: "?y -` PiE {0..<Suc n} F  space (PiM {0..<n} (λ_. M)) =
        (if y  F 0 then PiE {0..<n} (FSuc) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff extensional_def Ball_def split: nat.split nat.split_asm)

    have eq2: "?y -` PF.emb UNIV {0..<Suc n} (PiE {0..<Suc n} F)  space (PiM UNIV (λ_. M)) =
        (if y  F 0 then PF.emb UNIV {0..<n} (PiE {0..<n} (FSuc)) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff prod_emb_def extensional_def Ball_def split: nat.split nat.split_asm)

    let ?I = "indicator (F 0) y"

    have "C 1 n (?y ?U) = distr (y.C 0 n ?U) (ΠM i{0..<Suc n}. M) ?y"
    proof (induction n)
      case (Suc m)

      have "C 1 (Suc m) (?y ?U) = distr (y.C 0 m ?U) (PiM {0..<Suc m} (λi. M)) ?y  eP (Suc m)"
        using Suc by simp
      also have " = y.C 0 m ?U  (λx. eP (Suc m) (?y x))"
        by (intro bind_distr[where K="PiM {0..<Suc (Suc m)} (λ_. M)"]) (simp_all add: y y.space_C y.sets_C cong: measurable_cong_sets)
      also have " = y.C 0 m ?U  (λx. distr (y.eP m x) (PiM {0..<Suc (Suc m)} (λi. M)) ?y)"
      proof (intro bind_cong refl)
        fix ω' assume ω': "ω'  space (y.C 0 m ?U)"
        moreover have "K' x (Suc m) (?y ω') = K' y m ω'"
          by (auto simp: K'_def)
        ultimately show "eP (Suc m) (?y ω') = distr (y.eP m ω') (PiM {0..<Suc (Suc m)} (λi. M)) ?y"
          unfolding eP_def y.eP_def
          by (subst distr_distr)
             (auto simp: y.space_C y.sets_P split: nat.split cong: measurable_cong_sets
                   intro!: distr_cong measurable_fun_upd[where J="{0..<m}"])
      qed
      also have " = distr (y.C 0 m ?U  y.eP m) (PiM {0..<Suc (Suc m)} (λi. M)) ?y"
        by (intro distr_bind[symmetric, OF _ _ yM]) (auto simp: y.space_C y.sets_C cong: measurable_cong_sets)
      finally show ?case
        by simp
    qed (use y in simp add: PiM_empty distr_return›)
    then have "C 1 n (case_nat y ?U) (PiE {0..<Suc n} F) =
      (distr (y.C 0 n ?U) (ΠM i{0..<Suc n}. M) ?y) (PiE {0..<Suc n} F)" by simp
    also have " = ?I * y.C 0 n ?U (PiE {0..<n} (F  Suc))"
      by (subst emeasure_distr) (auto simp: y.sets_C y.space_C eq1 cong: measurable_cong_sets)
    also have " = ?I * lim_sequence y (PF.emb UNIV {0..<n} (PiE {0..<n} (F  Suc)))"
      using y by (simp add: emeasure_lim_sequence_emb_I0o sets_PiM_I_finite)
    also have " = distr (lim_sequence y) (PiM UNIV (λj. M)) ?y (PF.emb UNIV {0..<Suc n} (PiE {0..<Suc n} F))"
      using y by (subst emeasure_distr) (simp_all add: eq2 space_lim_sequence)
    finally show "emeasure (C 1 n (case_nat y (λ_. undefined))) (PiE {0..<Suc n} F) =
        emeasure (distr (lim_sequence y) (PiM UNIV (λj. M)) (case_nat y)) (PF.emb UNIV J (PiE J F'))"
      unfolding emb_eq .
  qed
  also have " =
    emeasure (K x  (λy. distr (lim_sequence y) (PiM UNIV (λj. M)) (case_nat y))) (PF.emb UNIV J (PiE J F'))"
    using J
    by (subst emeasure_bind[where N="PiM UNIV (λ_. M)"])
       (auto simp: sets_K x intro!: measurable_distr2[OF _ measurable_prob_algebraD[OF lim_sequence]] cong: measurable_cong_sets)
  finally show "emeasure (lim_sequence x) (PF.emb UNIV J (PiE J F')) =
    emeasure (K x  (λy. distr (lim_sequence y) (PiM UNIV (λj. M)) (case_nat y)))
            (PF.emb UNIV J (PiE J F'))" .
qed

lemma AE_lim_sequence:
  assumes x[simp]: "x  space M" and P[measurable]: "Measurable.pred (ΠM iUNIV. M) P"
  shows "(AE ω in lim_sequence x. P ω)  (AE y in K x. AE ω in lim_sequence y. P (case_nat y ω))"
  apply (simp add: lim_sequence_eq cong del: AE_cong)
  apply (subst AE_bind)
  apply (rule measurable_prob_algebraD)
  apply measurable
  apply (auto intro!: AE_cong simp add: space_K AE_distr_iff)
  done

definition lim_stream :: "'a  'a stream measure"
where
  "lim_stream x = distr (lim_sequence x) (stream_space M) to_stream"

lemma space_lim_stream: "space (lim_stream x) = streams (space M)"
  unfolding lim_stream_def by (simp add: space_stream_space)

lemma sets_lim_stream[measurable_cong]: "sets (lim_stream x) = sets (stream_space M)"
  unfolding lim_stream_def by simp

lemma lim_stream[measurable]: "lim_stream  M M prob_algebra (stream_space M)"
  unfolding lim_stream_def[abs_def] by (intro measurable_distr_prob_space2[OF lim_sequence]) auto

lemma space_stream_space_M_ne: "x  space M  space (stream_space M)  {}"
  using sconst_streams[of x "space M"] by (auto simp: space_stream_space)

lemma prob_space_lim_stream: "x  space M  prob_space (lim_stream x)"
  using measurable_space[OF lim_stream, of x] by (simp add: space_prob_algebra)

lemma lim_stream_eq:
  assumes x: "x  space M"
  shows "lim_stream x = do { y  K x; ω  lim_stream y; return (stream_space M) (y ## ω) }"
  unfolding lim_stream_def
  apply (subst lim_sequence_eq[OF x])
  apply (subst distr_bind[OF _ _ measurable_to_stream])
  subgoal
    by (auto simp: sets_K x cong: measurable_cong_sets
             intro!: measurable_prob_algebraD measurable_distr_prob_space2[where M="PiM UNIV (λj. M)"] lim_sequence) []
  subgoal
    using x by (auto simp add: space_K)
  apply (intro bind_cong refl)
  apply (subst distr_distr)
  apply (auto simp: space_K sets_lim_sequence x cong: measurable_cong_sets intro!: distr_cong)
  apply (subst bind_return_distr')
  apply (auto simp: space_stream_space_M_ne)
  apply (subst distr_distr)
  apply (auto simp: space_K sets_lim_sequence x to_stream_nat_case cong: measurable_cong_sets intro!: distr_cong)
  done

lemma AE_lim_stream:
  assumes x[simp]: "x  space M" and P[measurable]: "Measurable.pred (stream_space M) P"
  shows "(AE ω in lim_stream x. P ω)  (AE y in K x. AE ω in lim_stream y. P (y ## ω))"
  unfolding lim_stream_eq[OF x]
  by (simp_all add: space_K space_lim_stream space_stream_space AE_return AE_bind[OF measurable_prob_algebraD P] cong: AE_cong_simp)

lemma emeasure_lim_stream:
  assumes x[measurable, simp]: "x  space M" and A[measurable, simp]: "A  sets (stream_space M)"
  shows "lim_stream x A = (+y. emeasure (lim_stream y) (((##) y) -` A  space (stream_space M)) K x)"
  apply (subst lim_stream_eq, simp)
  apply (subst emeasure_bind[OF _ _ A], simp add: prob_space.not_empty prob_space_K)
   apply (rule measurable_prob_algebraD)
   apply measurable
  apply (intro nn_integral_cong)
  apply (subst bind_return_distr')
    apply (auto intro!: prob_space.not_empty prob_space_lim_stream simp: space_K emeasure_distr)
  apply (simp add: space_lim_stream space_stream_space)
  done

lemma lim_stream_eq_coinduct[case_names in_space step]:
  fixes R :: "'a  'a stream measure  bool"
  assumes x: "R x B" "x  space M"
  assumes R: "x B. R x B  B'M M prob_algebra (stream_space M).
    (AE y in K x. R y (B' y)  lim_stream y = B' y) 
    B = do { y  K x; ω  B' y; return (stream_space M) (y ## ω) }"
  shows "lim_stream x = B"
  using x
proof (coinduction arbitrary: x B rule: stream_space_coinduct[where M=M, case_names step])
  case (step x B)
  from R[OF R x B] obtain B' where B': "B'  M M prob_algebra (stream_space M)"
    and ae: "AE y in K x. R y (B' y)  lim_stream y = B' y"
    and eq: "B = K x  (λy. B' y  (λω. return (stream_space M) (y ## ω)))"
    by blast
  show ?case
    apply (rule bexI[of _ "K x"], rule bexI[OF _ lim_stream], rule bexI[OF _ B'])
    apply (intro conjI)
    subgoal
      using ae AE_space by eventually_elim (insert xspace M, auto simp: space_K)
    subgoal
      by (rule lim_stream_eq) fact
    subgoal
      by (rule eq)
    subgoal
      using K x  space M by (rule measurable_space)
    done
qed

lemma prob_space_lim_sequence: "x  space M  prob_space (lim_sequence x)"
  using measurable_space[OF lim_sequence, of x] by (simp add: space_prob_algebra)

end

subsection ‹Strong Markov Property for Discrete-Time Markov Processes›

text ‹The filtration adopted to streams, i.e. to the $n$-th projection.›

definition stream_filtration :: "'a measure  enat  'a stream measure"
  where "stream_filtration M n = (SUP i{i::nat. i  n}. vimage_algebra (streams (space M)) (λω . ω !! i) M)"

lemma measurable_stream_filtration1: "enat i  n  (λω. ω !! i)  stream_filtration M n M M"
  by (auto intro!: measurable_SUP1 measurable_vimage_algebra1 snth_in simp: stream_filtration_def)

lemma measurable_stream_filtration2:
  "f  space N  streams (space M)  (i. enat i  n  (λx. f x !! i)  N M M)  f  N M stream_filtration M n"
  by (auto simp: stream_filtration_def enat_0
           intro!: measurable_SUP2 measurable_vimage_algebra2 elim!: allE[of _ "0::nat"])

lemma space_stream_filtration: "space (stream_filtration M n) = space (stream_space M)"
  by (auto simp add: space_stream_space space_Sup_eq_UN stream_filtration_def enat_0 elim!: allE[of _ 0])

lemma sets_stream_filteration_le_stream_space: "sets (stream_filtration M n)  sets (stream_space M)"
  unfolding sets_stream_space_eq stream_filtration_def
  by (intro SUP_subset_mono le_measureD2) (auto simp: space_Sup_eq_UN enat_0 elim!: allE[of _ 0])

interpretation stream_filtration: filtration "space (stream_space M)" "stream_filtration M"
proof
  show "space (stream_filtration M i) = space (stream_space M)" for i
    by (simp add: space_stream_filtration)
  show "sets (stream_filtration M i)  sets (stream_filtration M j)" if "i  j" for i j
  proof (rule le_measureD2)
    show "stream_filtration M i  stream_filtration M j"
      using i  j unfolding stream_filtration_def by (intro SUP_subset_mono) auto
  qed (simp add: space_stream_filtration)
qed

lemma measurable_stopping_time_stream:
  "stopping_time (stream_filtration M) T  T  stream_space M M count_space UNIV"
  using sets_stream_filteration_le_stream_space
  by (subst measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric, where 'a=enat]])
     (auto intro!: measurable_stopping_time simp: space_stream_filtration)

lemma measurable_stopping_time_All_eq_0:
  assumes T: "stopping_time (stream_filtration M) T"
  shows "{xspace M. ωstreams (space M). T (x ## ω) = 0}  sets M"
proof -
  have "{ωstreams (space M). T ω = 0}  vimage_algebra (streams (space M)) (λω. ω !! 0) M"
    using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
  then obtain A
    where A: "A  sets M"
      and *: "{ω  streams (space M). T ω = 0} = (λω. ω !! 0) -` A  streams (space M)"
    by (auto simp: sets_vimage_algebra2 streams_shd)
  have "A = {xspace M. ωstreams (space M). T (x ## ω) = 0}"
  proof safe
    fix x ω assume "x  A" "ω  streams (space M)"
    then have "x ## ω  {ω  streams (space M). T ω = 0}"
      unfolding * using A[THEN sets.sets_into_space] by auto
    then show "T (x ## ω) = 0" by auto
  next
    fix x assume "x  space M" "ωstreams (space M). T (x ## ω) = 0 "
    then have "ωstreams (space M). x ## ω  {ω  streams (space M). T ω = 0}"
      by simp
    with xspace M show "x  A"
      unfolding * by (auto simp: streams_empty_iff)
  qed (use A[THEN sets.sets_into_space] in auto)
  with A  sets M show ?thesis by auto
qed

lemma stopping_time_0:
  assumes T: "stopping_time (stream_filtration M) T"
    and x: "x  space M" and ω: "ω  streams (space M)" "T (x ## ω) > 0"
    and ω': "ω'  streams (space M)"
  shows "T (x ## ω') > 0"
  unfolding zero_less_iff_neq_zero
proof
  assume "T (x ## ω') = 0"
  with x ω' have x': "x ## ω'  {ω  streams (space M). T ω = 0}"
    by auto

  have "{ωstreams (space M). T ω = 0}  vimage_algebra (streams (space M)) (λω. ω !! 0) M"
    using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
  then obtain A
    where A: "A  sets M"
      and *: "{ω  streams (space M). T ω = 0} = (λω. ω !! 0) -` A  streams (space M)"
    by (auto simp: sets_vimage_algebra2 streams_shd)
  with x' have "x  A"
    by auto
  with ω x have "x ## ω  (λω. ω !! 0) -` A  streams (space M)"
    by auto
  with ω show False
    unfolding *[symmetric] by auto
qed

lemma stopping_time_epred_SCons:
  assumes T: "stopping_time (stream_filtration M) T"
    and x: "x  space M" and ω: "ω  streams (space M)" "T (x ## ω) > 0"
  shows "stopping_time (stream_filtration M) (λω. epred (T (x ## ω)))"
proof (rule stopping_timeI, rule measurable_cong[THEN iffD2])
  show "ω  space (stream_filtration M t)  (epred (T (x ## ω))  t) = (T (x ## ω)  eSuc t)" for t ω
    by (cases "T (x ## ω)" rule: enat_coexhaust)
       (auto simp add: space_stream_filtration space_stream_space dest!: stopping_time_0[OF T x ω])
  show "Measurable.pred (stream_filtration M t) (λw. T (x ## w)  eSuc t)" for t
  proof (rule measurable_compose[of "SCons x"])
    show "(##) x  stream_filtration M t M stream_filtration M (eSuc t)"
    proof (intro measurable_stream_filtration2)
      show "enat i  eSuc t  (λxa. (x ## xa) !! i)  stream_filtration M t M M" for i
        using xspace M
        by (cases i) (auto simp: eSuc_enat[symmetric] intro!: measurable_stream_filtration1)
    qed (auto simp: space_stream_filtration space_stream_space xspace M)
  qed (rule T[THEN stopping_timeD])
qed

context discrete_Markov_process
begin

lemma lim_stream_strong_Markov:
  assumes x: "x  space M" and T: "stopping_time (stream_filtration M) T"
  shows "lim_stream x =
    lim_stream x  (λω. case T ω of
      enat i  distr (lim_stream (ω !! i)) (stream_space M) (λω'. stake (Suc i) ω @- ω')
    |       return (stream_space M) ω)"
  (is "_ = ?L T x")
  using assms
proof (coinduction arbitrary: x T rule: lim_stream_eq_coinduct)
  case (step x T)
  note T = ‹stopping_time (stream_filtration M) T[THEN measurable_stopping_time_stream, measurable]
  define L where "L T x = ?L T x" for T x
  have L[measurable (raw)]:
    "(λ(x, ω). T x ω)  N M stream_space M M count_space UNIV 
    f  N M M  (λx. L (T x) (f x))  N M prob_algebra (stream_space M)" for f :: "'a  'a" and N T
    unfolding L_def
    by (intro measurable_bind_prob_space2[OF measurable_compose[OF _ lim_stream]] measurable_case_enat
        measurable_distr_prob_space2[OF measurable_compose[OF _ lim_stream]]
        measurable_return_prob_space measurable_stopping_time_stream)
       auto

  define S where "S x = (if ωstreams (space M). T (x##ω) = 0 then lim_stream x else L (λω. epred (T (x ## ω))) x)" for x
  then have S_eq: "ωstreams (space M). T (x##ω) = 0  S x = lim_stream x"
    "¬ (ωstreams (space M). T (x##ω) = 0)  S x = L (λω. epred (T (x ## ω))) x" for x
    by auto
  have [measurable]: "S  M M prob_algebra (stream_space M)"
    unfolding S_def[abs_def]
    by (subst measurable_If_restrict_space_iff, safe intro!: L)
       (auto intro!: measurable_stopping_time_All_eq_0 step measurable_restrict_space1 lim_stream
                     measurable_compose[OF _ measurable_epred] measurable_compose[OF _ T]
                     measurable_Stream measurable_compose[OF measurable_fst]
             simp: measurable_split_conv)

  show ?case
    unfolding L_def[symmetric]
  proof (intro bexI[of _ S] conjI AE_I2)
    fix y assume "y  space (K x)"
    then show "(x T. y = x  S y = L T x  x  space M  stopping_time (stream_filtration M) T) 
      lim_stream y = S y"
      using xspace M
      by (cases "ωstreams (space M). T (y##ω) = 0")
         (auto simp add: S_eq space_K intro!: exI[of _ "λω. epred (T (y ## ω))"] stopping_time_epred_SCons step)
  next
    note xspace M[simp]
    have "L T x = K x 
      (λy. lim_stream y  (λω. case T (y##ω) of
            enat i  distr (lim_stream ((y##ω) !! i)) (stream_space M) (λω'. stake (Suc i) (y##ω) @- ω')
          |       return (stream_space M) (y##ω)))" (is "_ = K x  ?L'")
      unfolding L_def
      apply (subst lim_stream_eq[OF xspace M])
      apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
          measurable)
      apply (rule bind_cong[OF refl])
      apply (simp add: space_K)
      apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
          measurable)
      apply (rule bind_cong[OF refl])
      apply (simp add: space_lim_stream)
      apply (subst bind_return[where N="stream_space M", OF measurable_prob_algebraD])
        apply (measurable; fail) []
       apply (simp add: space_stream_space)
      apply rule
      done
    also have " = K x  (λy. S y  (λω. return (stream_space M) (y ## ω)))"
    proof (intro bind_cong[of "K x"] refl)
      fix y assume "y  space (K x)"
      then have [simp]: "y  space M"
        by (simp add: space_K)
      show "?L' y = S y  (λω. return (stream_space M) (y ## ω))"
      proof cases
        assume "ωstreams (space M). T (y##ω) = 0"
        with x show ?thesis
          by (auto simp: S_eq space_lim_stream shift.simps[abs_def] streams_empty_iff
                bind_const'[OF _ prob_space_imp_subprob_space] prob_space_lim_stream prob_space.prob_space_distr
              intro!: bind_return_distr'[symmetric]
              cong: bind_cong_simp)
      next
        assume *: "¬ (ωstreams (space M). T (y##ω) = 0)"
        then have T_pos: "ω  streams (space M)  T (y ## ω)  0" for ω
          using stopping_time_0[OF ‹stopping_time (stream_filtration M) T, of y _ ω] by auto
        show ?thesis
          apply (simp add: S_eq(2)[OF *] L_def)
          apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
            measurable)
          apply (intro bind_cong refl)
          apply (auto simp: T_pos enat_0 space_lim_stream shift.simps[abs_def] diff_Suc space_stream_space
                      intro!: bind_return[where N="stream_space M", OF measurable_prob_algebraD, symmetric]
                        bind_distr_return[symmetric]
                      split: nat.split enat.split)
          done
      qed
    qed
    finally show "L T x = K x  (λy. S y  (λω. return (stream_space M) (y ## ω)))" .
  qed fact
qed fact

end

end

Theory Continuous_Time_Markov_Chain

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Continuous-time Markov chains›

theory Continuous_Time_Markov_Chain
  imports Discrete_Time_Markov_Process Discrete_Time_Markov_Chain
begin

subsection ‹Trace Operations: relate @{typ "('a × real) stream"} and @{typ "real  'a"}

partial_function (tailrec) trace_at :: "'a  (real × 'a) stream  real  'a"
where
  "trace_at s ω j = (case ω of (t', s')##ω  if t'  j then trace_at s' ω j else s)"

lemma trace_at_simp[simp]: "trace_at s ((t', s')##ω) j = (if t'  j then trace_at s' ω j else s)"
  by (subst trace_at.simps) simp

lemma trace_at_eq:
  "trace_at s ω j = (case sfirst (λx. j < fst (shd x)) ω of   undefined | enat i  (s ## smap snd ω) !! i)"
proof (split enat.split; safe)
  assume "sfirst (λx. j < fst (shd x)) ω = "
  with sfirst_finite[of "λx. j < fst (shd x)" ω]
  have "alw (λx. fst (shd x)  j) ω"
    by (simp add: not_ev_iff not_less)
  then show "trace_at s ω j = undefined"
    by (induction arbitrary: s ω rule: trace_at.fixp_induct) (auto split: stream.split)
next
  show "sfirst (λx. j < fst (shd x)) ω = enat n  trace_at s ω j = (s ## smap snd ω) !! n" for n
  proof (induction n arbitrary: s ω)
    case 0 then show ?case
      by (subst trace_at.simps) (auto simp add: enat_0 sfirst_eq_0 split: stream.split)
  next
    case (Suc n) show ?case
      using sfirst.simps[of "λx. j < fst (shd x)" ω] Suc.prems Suc.IH[of "stl ω" "snd (shd ω)"]
      by (cases ω) (auto simp add: eSuc_enat[symmetric] split: stream.split if_split_asm)
  qed
qed

lemma trace_at_shift: "trace_at s (smap (λ(t, s'). (t + t', s')) ω) t = trace_at s ω (t - t')"
  by (induction arbitrary: s ω rule: trace_at.fixp_induct) (auto split: stream.split)

primcorec merge_at :: "(real × 'a) stream  real  (real × 'a) stream  (real × 'a) stream"
where
  "merge_at ω j ω' = (case ω of (t, s) ## ω  if t  j then (t, s)##merge_at ω j ω' else ω')"

lemma merge_at_simp[simp]: "merge_at (x##ω) j ω' = (if fst x  j then x##merge_at ω j ω' else ω')"
  by (cases x) (subst merge_at.code; simp)

subsection ‹Exponential Distribution›

definition exponential :: "real  real measure"
where
  "exponential l = density lborel (exponential_density l)"

lemma space_exponential: "space (exponential l) = UNIV"
  by (simp add: exponential_def)

lemma sets_exponential[measurable_cong]: "sets (exponential l) = sets borel"
  by (simp add: exponential_def)

lemma prob_space_exponential: "0 < l  prob_space (exponential l)"
  unfolding exponential_def by (intro prob_space_exponential_density)

lemma AE_exponential: "0 < l  AE x in exponential l. 0 < x"
  unfolding exponential_def using AE_lborel_singleton[of 0] by (auto simp add: AE_density exponential_density_def)

lemma emeasure_exponential_Ioi_cutoff:
  assumes "0 < l"
  shows "emeasure (exponential l) {x <..} = exp (- (max 0 x) * l)"
proof -
  interpret prob_space "exponential l"
    unfolding exponential_def using 0<l by (rule prob_space_exponential_density)
  have *: "prob {xa  space (exponential l). max 0 x < xa} = exp (- max 0 x * l)"
    apply (rule exponential_distributedD_gt[OF _ _ 0<l])
    apply (auto simp: exponential_def distributed_def)
    apply (subst (6) distr_id[symmetric])
    apply (subst (2) distr_cong)
    apply simp_all
    done
  have "emeasure (exponential l) {x <..} = emeasure (exponential l) {max 0 x <..}"
    using AE_exponential[OF 0<l] by (intro emeasure_eq_AE) auto
  also have " = exp (- (max 0 x) * l)"
    using * unfolding emeasure_eq_measure by (simp add: space_exponential greaterThan_def)
  finally show ?thesis .
qed

lemma emeasure_exponential_Ioi:
  "0 < l  0  x  emeasure (exponential l) {x <..} = exp (- x * l)"
  using emeasure_exponential_Ioi_cutoff[of l x] by simp

lemma exponential_eq_stretch:
  assumes "0 < l"
  shows "exponential l = distr (exponential 1) borel (λx. (1/l) * x)"
proof (intro measure_eqI)
  fix A assume "A  sets (exponential l)"
  then have [measurable]: "A  sets borel"
    by (simp add: sets_exponential)
  then have [measurable]: "(λx. x / l) -` A  sets borel"
    by (rule measurable_sets_borel[rotated]) simp
  have "emeasure (exponential l) A =
    (+x. ennreal l * (indicator (((*) (1/l) -` A)  {0 ..}) (l * x) * ennreal (exp (- (l * x)))) lborel)"
    using 0 < l
    by (auto simp: ac_simps emeasure_distr exponential_def emeasure_density exponential_density_def
                   ennreal_mult zero_le_mult_iff
             intro!: nn_integral_cong split: split_indicator)
  also have " = (+x. indicator (((*) (1/l) -` A)  {0 ..}) x * ennreal (exp (- x)) lborel)"
    using 0<l
    apply (subst nn_integral_stretch)
      apply (auto simp: nn_integral_cmult)
    apply (simp add: ennreal_mult[symmetric] mult.assoc[symmetric])
    done
  also have " = emeasure (distr (exponential 1) borel (λx. (1/l) * x)) A"
    by (auto simp add: emeasure_distr exponential_def emeasure_density exponential_density_def
        intro!: nn_integral_cong split: split_indicator)
  finally show "emeasure (exponential l) A = emeasure (distr (exponential 1) borel (λx. (1/l) * x)) A" .
qed (simp add: sets_exponential)

lemma uniform_measure_exponential:
  assumes "0 < l" "0  t"
  shows "uniform_measure (exponential l) {t <..} = distr (exponential l) borel ((+) t)" (is "?L = ?R")
proof (rule measure_eqI_lessThan)
  fix x
  have "0 < emeasure (exponential l) {t<..}"
    unfolding emeasure_exponential_Ioi[OF assms] by simp
  with assms show "?L {x<..} < "
    by (simp add: ennreal_divide_eq_top_iff less_top[symmetric] lessThan_Int_lessThan
      emeasure_exponential_Ioi)
  have *: "((+) t -` {x<..}  space (exponential l)) = {x - t <..}"
    by (auto simp: space_exponential)
  show "?L {x<..} = ?R {x<..}"
    using assms by (simp add: lessThan_Int_lessThan emeasure_exponential_Ioi divide_ennreal
      emeasure_distr * emeasure_exponential_Ioi_cutoff exp_diff[symmetric] field_simps split: split_max)
qed (auto simp: sets_exponential)

lemma emeasure_PiM_exponential_Ioi_finite:
  assumes "J  I" "finite J" "i. i  I  0 < R i" "0  x"
  shows "emeasure (ΠM iI. exponential (R i)) (prod_emb I (λi. exponential (R i)) J (ΠE jJ. {x<..})) = exp (- x * (iJ. R i))"
proof (subst emeasure_PiM_emb)
  from assms show "(iJ. emeasure (exponential (R i)) {x<..}) = ennreal (exp (- x * sum R J))"
    by (subst prod.cong[OF refl emeasure_exponential_Ioi])
       (auto simp add: prod_ennreal exp_sum sum_negf[symmetric] sum_distrib_left)
qed (insert assms, auto intro!: prob_space_exponential)

lemma emeasure_PiM_exponential_Ioi_sequence:
  assumes R: "summable R" "i. 0 < R i" "0  x"
  shows "emeasure (ΠM iUNIV. exponential (R i)) (Π iUNIV. {x<..}) = exp (- x * suminf R)"
proof -
  let ?R = "λi. exponential (R i)" let ?P = "ΠM iUNIV. ?R i"
  let ?N = "λn::nat. prod_emb UNIV ?R {..<n} (ΠE i{..<n}. {x<..})"
  interpret prob_space ?P
    by (intro prob_space_PiM prob_space_exponential R)
  have "(ΠM iUNIV. exponential (R i)) (n. ?N n) = (INF n. (ΠM iUNIV. exponential (R i)) (?N n))"
    by (intro INF_emeasure_decseq[symmetric] decseq_emb_PiE) (auto simp: incseq_def)
  also have " = (INF n. ennreal (exp (- x * (i<n. R i))))"
    using R by (intro INF_cong emeasure_PiM_exponential_Ioi_finite) auto
  also have " = ennreal (exp (- x * (SUP n. (i<n. R i))))"
    using R
    by (subst continuous_at_Sup_antimono[where f="λr. ennreal (exp (- x * r))"])
       (auto intro!: bdd_aboveI2[where M="i. R i"] sum_le_suminf summable_mult mult_left_mono
                     continuous_mult continuous_at_ennreal continuous_within_exp[THEN continuous_within_compose3] continuous_minus
             simp: less_imp_le antimono_def image_comp)
  also have " = ennreal (exp (- x * (i. R i)))"
    using R by (subst suminf_eq_SUP_real) (auto simp: less_imp_le)
  also have "(n. ?N n) = (Π iUNIV. {x<..})"
    by (fastforce simp: prod_emb_def Pi_iff PiE_iff space_exponential)
  finally show ?thesis
    using R by simp
qed

lemma emeasure_PiM_exponential_Ioi_countable:
  assumes R: "J  I" "countable J" "i. i  I  0 < R i" "0  x" and finite: "integrable (count_space J) R"
  shows "emeasure (ΠM iI. exponential (R i)) (prod_emb I (λi. exponential (R i)) J (ΠE jJ. {x<..})) =
    exp (- x * (LINT i|count_space J. R i))"
proof cases
  assume "finite J" with assms show ?thesis
    by (subst emeasure_PiM_exponential_Ioi_finite)
       (auto simp: lebesgue_integral_count_space_finite)
next
  assume "infinite J"
  let ?R = "λi. exponential (R i)" let ?P = "ΠM iI. ?R i"
  define f where "f = from_nat_into J"
  have J_eq: "J = range f" and f: "inj f" "f  UNIV  I"
    using from_nat_into_inj_infinite[of J] range_from_nat_into[of J] ‹countable J ‹infinite J J  I
    by (auto simp: inj_on_def f_def simp del: range_from_nat_into)
  have Bf: "bij_betw f UNIV J"
    unfolding J_eq using inj_on_imp_bij_betw[OF f(1)] .

  have summable_R: "summable (λi. R (f i))"
    using finite unfolding integrable_bij_count_space[OF Bf, symmetric] integrable_count_space_nat_iff
    by (rule summable_norm_cancel)

  have "emeasure (ΠM iUNIV. exponential (R (f i))) (Π iUNIV. {x<..}) = exp (- x * (i. R (f i)))"
    using finite assms unfolding J_eq by (intro emeasure_PiM_exponential_Ioi_sequence[OF summable_R]) auto
  also have "(ΠM iUNIV. exponential (R (f i))) = distr ?P (ΠM iUNIV. exponential (R (f i))) (λω. λiUNIV. ω (f i))"
    using R by (intro distr_PiM_reindex[symmetric, OF _ f] prob_space_exponential) auto
  also have " (Π iUNIV. {x<..}) = ?P ((λω. λiUNIV. ω (f i)) -` (Π iUNIV. {x<..})  space ?P)"
    using f(2) by (intro emeasure_distr infprod_in_sets) (auto simp: Pi_iff)
  also have "(λω. λiUNIV. ω (f i)) -` (Π iUNIV. {x<..})  space ?P = prod_emb I ?R J (ΠE jJ. {x<..})"
    by (auto simp: prod_emb_def space_PiM space_exponential Pi_iff J_eq)
  also have "(i. R (f i)) = (LINT i|count_space J. R i)"
    using finite
    by (subst integral_count_space_nat[symmetric])
       (auto simp: integrable_bij_count_space[OF Bf] integral_bij_count_space[OF Bf])
  finally show ?thesis .
qed

lemma AE_PiM_exponential_suminf_infty:
  fixes R :: "nat  real"
  assumes R: "n. 0 < R n" and finite: "(n. ennreal (1 / R n)) = top"
  shows "AE ω in ΠM nUNIV. exponential (R n). (n. ereal (ω n)) = "
proof -
  let ?P = "ΠM nUNIV. exponential (R n)"
  interpret prob_space "exponential (R n)" for n
    by (intro prob_space_exponential R)
  interpret product_prob_space "λn. exponential (R n)" UNIV
    proof qed

  have AE_pos: "AE ω in ?P. i. 0 < ω i"
    unfolding AE_all_countable by (intro AE_PiM_component allI prob_space_exponential R AE_exponential) simp

  have indep: "indep_vars (λi. borel) (λi x. x i) UNIV"
    using PiM_component
    apply (subst P.indep_vars_iff_distr_eq_PiM)
     apply (auto simp: restrict_UNIV distr_id2)
    apply (subst distr_id2)
     apply (intro sets_PiM_cong)
      apply (auto simp: sets_exponential cong: distr_cong)
    done

  have [simp]: "0  x + x * R i  0  x" for x i
    using zero_le_mult_iff[of x "1 + R i"] R[of i] by (simp add: field_simps)

  have "(+ω. eexp (n. - ereal (ω n)) ?P) = (+ω. (INF n. i<n. eexp (- ereal (ω i))) ?P)"
  proof (intro nn_integral_cong_AE, use AE_pos in eventually_elim)
    fix ω :: "nat  real" assume ω: "i. 0 < ω i"
    show "eexp (n. - ereal (ω n)) = (n. i<n. eexp (- ereal (ω i)))"
    proof (rule LIMSEQ_unique[OF _ LIMSEQ_INF])
      show "(λi. i<i. eexp (- ereal (ω i)))  eexp (n. - ereal (ω n))"
        using ω by (intro eexp_suminf summable_minus_ereal summable_ereal_pos) (auto intro: less_imp_le)
      show "decseq (λn. i<n. eexp (- ereal (ω i)))"
        using ω by (auto simp: decseq_def intro!: prod_mono3 intro: less_imp_le)
    qed
  qed
  also have " = (INF n. (+ω. (i<n. eexp (- ereal (ω i))) ?P))"
  proof (intro nn_integral_monotone_convergence_INF_AE')
    show "AE ω in ?P. (i<Suc n. eexp (- ereal (ω i)))  (i<n. eexp (- ereal (ω i)))" for n
      using AE_pos
    proof eventually_elim
      case (elim ω)
      show ?case
        by (rule prod_mono3) (auto simp: elim le_less)
    qed
  qed (auto simp: less_top[symmetric])
  also have " = (INF n. (i<n. (+ω. eexp (- ereal (ω i)) ?P)))"
  proof (intro INF_cong refl indep_vars_nn_integral)
    show "indep_vars (λ_. borel) (λi ω. eexp (- ereal (ω i))) {..<n}" for n
    proof (rule indep_vars_compose2[of _ _ _ "λi x. eexp(- ereal x)"])
      show "indep_vars (λi. borel) (λi x. x i) {..<n}"
        by (rule indep_vars_subset[OF indep]) auto
    qed auto
  qed auto
  also have " = (INF n. (i<n. R i * (+x. indicator {0 ..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) lborel)))"
    by (subst product_nn_integral_component)
       (auto simp: field_simps exponential_def nn_integral_density ennreal_mult'[symmetric] ennreal_mult''[symmetric]
                   exponential_density_def exp_diff exp_minus nn_integral_cmult[symmetric]
             intro!: INF_cong prod.cong nn_integral_cong split: split_indicator)
  also have " = (INF n. (i<n. ennreal (R i / (1 + R i))))"
  proof (intro INF_cong prod.cong refl)
    show "R i * (+ x. indicator {0..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) lborel) =
      ennreal (R i / (1 + R i))" for i
      using nn_intergal_power_times_exp_Ici[of 0] 0 < R i
      by (subst nn_integral_stretch[where c="1 + R i"])
         (auto simp: mult.assoc[symmetric] ennreal_mult''[symmetric] less_imp_le mult.commute)
  qed
  also have " = (INF n. ennreal (i<n. R i / (1 + R i)))"
    using R by (intro INF_cong refl prod_ennreal divide_nonneg_nonneg) (auto simp: less_imp_le)
  also have " = (INF n. ennreal (inverse (i<n. (1 + R i) / R i)))"
    by (subst prod_inversef[symmetric]) simp_all
  also have " = (INF n. inverse (ennreal (i<n. (1 + R i) / R i)))"
    using R by (subst inverse_ennreal) (auto intro!: prod_pos divide_pos_pos simp: add_pos_pos)
  also have " = inverse (SUP n. ennreal (i<n. (1 + R i) / R i))"
    by (subst continuous_at_Sup_antimono [where f = inverse])
      (auto simp: antimono_def image_comp intro!: continuous_on_imp_continuous_within[OF continuous_on_inverse_ennreal'])
  also have "(SUP n. ennreal (i<n. (1 + R i) / R i)) = top"
  proof (cases "SUP n. ennreal (i<n. (1 + R i) / R i)")
    case (real r)
    have "(λn. ennreal (i<n. (1 + R i) / R i))  r"
      using R unfolding real(2)[symmetric]
      by (intro LIMSEQ_SUP monoI ennreal_leI prod_mono2) (auto intro!: divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le)
    then have "(λn. (i<n. (1 + R i) / R i))  r"
      by (rule tendsto_ennrealD)
         (use R real in auto intro!: always_eventually prod_nonneg divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le›)
    moreover have "(1 + R i) / R i = 1 / R i + 1" for i
      using 0 < R i by (auto simp: field_simps)
    ultimately have "convergent (λn. i<n. 1 / R i + 1)"
      by (auto simp: convergent_def)
    then have "summable (λi. 1 / R i)"
      using R by (subst summable_iff_convergent_prod) (auto intro: less_imp_le)
    moreover have "0  1 / R i" for i
      using R by (auto simp: less_imp_le)
    ultimately show ?thesis
      using finite ennreal_suminf_neq_top[of "λi. 1 / R i"] by blast
  qed
  finally have "(+ω. eexp (n. - ereal (ω n)) ?P) = 0"
    by simp
  then have "AE ω in ?P. eexp (n. - ereal (ω n)) = 0"
    by (subst (asm) nn_integral_0_iff_AE) auto
  then show ?thesis
    using AE_pos
  proof eventually_elim
    show "(i. 0 < ω i)  eexp (n. - ereal (ω n)) = 0  (n. ereal (ω n)) = " for ω
      apply (auto simp del: uminus_ereal.simps simp add: uminus_ereal.simps[symmetric]
                  intro!: summable_iff_suminf_neq_top intro: less_imp_le)
      apply (subst (asm) suminf_minus_ereal)
      apply (auto intro!: summable_ereal_pos intro: less_imp_le)
      done
  qed
qed

subsection ‹Transition Rates›

locale transition_rates =
  fixes R :: "'a  'a  real"
  assumes R_nonneg[simp]: "x y. 0  R x y"
  assumes R_diagonal_0[simp]: "x. R x x = 0"
  assumes finite_weight: "x. (+y. R x y count_space UNIV) < "
  assumes positive_weight: "x. 0 < (+y. R x y count_space UNIV)"
begin

abbreviation S :: "(real × 'a) measure"
where "S  (borel M count_space UNIV)"

abbreviation T :: "(real × 'a) stream measure"
where "T  stream_space S"

abbreviation I :: "'a  'a set"
where "I x  {y. 0 < R x y}"

lemma I_countable: "countable (I x)"
proof -
  let ?P = "point_measure UNIV (R x)"
  interpret finite_measure ?P
  proof
    show "emeasure ?P (space ?P)  "
      using finite_weight
      by (simp add: emeasure_density point_measure_def less_top)
  qed
  from countable_support emeasure_point_measure_finite2[of "{_}" UNIV "R x"]
  show ?thesis
    by (simp add: emeasure_eq_measure less_le)
qed

definition escape_rate :: "'a  real" where
  "escape_rate x = y. R x y count_space UNIV"

lemma ennreal_escape_rate: "ennreal (escape_rate x) = (+y. R x y count_space UNIV)"
  using finite_weight[of x] unfolding escape_rate_def
  by (intro nn_integral_eq_integral[symmetric]) (auto simp: integrable_iff_bounded)

lemma escape_rate_pos: "0 < escape_rate x"
  using positive_weight unfolding ennreal_escape_rate[symmetric] by simp

lemma nonneg_escape_rate[simp]: "0  escape_rate x"
  using escape_rate_pos[THEN less_imp_le] .

lemma prob_space_exponential_escape_rate: "prob_space (exponential (escape_rate x))"
  using escape_rate_pos by (rule prob_space_exponential)

lemma measurable_escape_rate[measurable]: "escape_rate  count_space UNIV M borel"
  by auto

lemma measurable_exponential_escape_rate[measurable]: "(λx. exponential (escape_rate x))  count_space UNIV M prob_algebra borel"
  by (auto simp: space_prob_algebra sets_exponential prob_space_exponential_escape_rate)

interpretation pmf_as_function .

lift_definition J :: "'a  'a pmf" is "λx y.  R x y / escape_rate x"
proof safe
  show "0  R x y / escape_rate x" for x y
    by (auto intro!: integral_nonneg_AE divide_nonneg_nonneg R_nonneg simp: escape_rate_def)
  show "(+y. R x y / escape_rate x count_space UNIV) = 1" for x
    using escape_rate_pos[of x]
    by (auto simp add: divide_ennreal[symmetric] nn_integral_divide ennreal_escape_rate[symmetric] intro!: ennreal_divide_self)
qed

lemma set_pmf_J: "set_pmf (J x) = I x"
  using escape_rate_pos[of x] by (auto simp: set_pmf_iff J.rep_eq less_le)

interpretation exp_esc: pair_prob_space "distr (exponential (escape_rate x)) borel ((+) t)" "J x" for x
proof -
  interpret prob_space "distr (exponential (escape_rate x)) borel ((+) t)"
    by (intro prob_space.prob_space_distr prob_space_exponential_escape_rate) simp
  show "pair_prob_space (distr (exponential (escape_rate x)) borel ((+) t)) (measure_pmf (J x))"
    by standard
qed

subsection ‹Continuous-time Kernel›

definition K :: "(real × 'a)  (real × 'a) measure" where
  "K = (λ(t, x). (distr (exponential (escape_rate x)) borel ((+) t)) M J x)"

interpretation K: discrete_Markov_process "borel M count_space UNIV" K
proof
  show "K  borel M count_space UNIV M prob_algebra (borel M count_space UNIV)"
    unfolding K_def
    apply measurable
    apply (rule measurable_snd[THEN measurable_compose])
    apply (auto simp: space_prob_algebra prob_space_measure_pmf)
    done
qed

interpretation DTMC: MC_syntax J .

lemma in_space_S[simp]: "x  space S"
  by (simp add: space_pair_measure)

lemma in_space_T[simp]: "x  space T"
  by (simp add: space_pair_measure space_stream_space)

lemma in_space_lim_stream: "ω  space (K.lim_stream x)"
  unfolding K.space_lim_stream space_stream_space[symmetric] by simp

lemma prob_space_K_lim: "prob_space (K.lim_stream x)"
  using K.lim_stream[THEN measurable_space] by (simp add: space_prob_algebra)

definition select_first :: "'a  ('a  real)  'a  bool"
where "select_first x p y = (y  I x  (y'I x - {y}. p y < p y'))"

lemma select_firstD1: "select_first x p y  y  I x"
  by (simp add: select_first_def)

lemma select_first_unique:
  assumes y: "select_first x p y1" " select_first x p y2" shows "y1 = y2"
proof -
  have "y1  y2  p y1 < p y2" "y1  y2  p y2 < p y1"
    using y by (auto simp: select_first_def)
  then show "y1 = y2"
    by (rule_tac ccontr) auto
qed

lemma The_select_first[simp]: "select_first x p y  The (select_first x p) = y"
  by (intro the_equality select_first_unique)

lemma select_first_INF:
  "select_first x p y  (INF xI x. p x) = p y"
  by (intro antisym cINF_greatest cINF_lower bdd_belowI2[where m="p y"])
     (auto simp: select_first_def le_less)

lemma measurable_select_first[measurable]:
  "(λp. select_first x p y)  (ΠM yI x. borel) M count_space UNIV"
  using I_countable unfolding select_first_def by (intro measurable_pred_countable pred_intros_conj1') measurable

lemma measurable_THE_select_first[measurable]:
  "(λp. The (select_first x p))  (ΠM yI x. borel) M count_space UNIV"
  by (rule measurable_THE) (auto intro: select_first_unique I_countable dest: select_firstD1)

lemma sets_S_eq: "sets S = sigma_sets UNIV { {t ..} × A | t A. A  - I x  (sI x. A = {s}) }"
proof (subst sets_pair_eq)
  let ?CI = "λa::real. {a ..}" let ?Ea = "range ?CI"

  show "?Ea  Pow (space borel)" "sets borel = sigma_sets (space borel) ?Ea"
    unfolding borel_Ici by auto
  show "?CI`Rats  ?Ea" "(iRats. ?CI i) = space borel"
    using Rats_dense_in_real[of "x - 1" "x" for x] by (auto intro: less_imp_le)

  let ?Eb = "Pow (- I x)  (λs. {s}) ` I x"
  have "b  sigma_sets UNIV (Pow (- I x)  (λs. {s}) ` I x)" for b
  proof -
    have "b = (b - I x)  (xb  I x. {x})"
      by auto
    also have "  sigma UNIV (Pow (- I x)  (λs. {s}) ` I x)"
      using I_countable by (intro sets.Un sets.countable_UN') auto
    finally show ?thesis
      by simp
  qed
  then show "sets (count_space UNIV) = sigma_sets (space (count_space UNIV)) ?Eb"
    by auto
  show "countable ({- I x}  (sI x. {{s}}))"
    using I_countable by auto
  show "sets (sigma (space borel × space (count_space UNIV)) {a × b |a b. a  ?Ea  b  ?Eb}) =
    sigma_sets UNIV {{t ..} × A |t A. A  - I x  (sI x. A = {s})}"
    apply simp
    apply (intro arg_cong[where f="sigma_sets _"])
    apply auto
    done
qed (auto intro: countable_rat)

subsection ‹Kernel equals Parallel Choice›

abbreviation PAR :: "'a  ('a  real) measure"
where
  "PAR x  (ΠM yI x. exponential (R x y))"

lemma PAR_least:
  assumes y: "y  I x"
  shows "PAR x {pspace (PAR x). t  p y  select_first x p y} =
     emeasure (exponential (escape_rate x)) {t ..} * ennreal (pmf (J x) y)"
proof -
  let ?E = "λy. exponential (R x y)" let ?P' = "ΠM yI x - {y}. ?E y"
  interpret P': prob_space ?P'
    by (intro prob_space_PiM prob_space_exponential) simp
  have *: "PAR x = (ΠM yinsert y (I x - {y}). ?E y)"
    using y by (intro PiM_cong) auto
  have "0 < R x y"
    using y by simp
  have **: "(λ(x, X). X(y := x))  exponential (R x y) M PiM (I x - {y}) (λi. exponential (R x i)) M PAR x"
    using y
    apply (subst measurable_cong_sets[OF sets_pair_measure_cong[OF sets_exponential sets_PiM_cong[OF refl sets_exponential]] sets_PiM_cong[OF refl sets_exponential]])
    apply measurable
    apply (rule measurable_fun_upd[where J="I x - {y}"])
    apply auto
    done
  have "PAR x {pspace (PAR x). t  p y  (y'I x-{y}. p y < p y')} =
    (+ty. indicator {t..} ty * ?P' {pspace ?P'. y'I x-{y}. ty < p y'} ?E y)"
    unfolding * using y  I x
    apply (subst distr_pair_PiM_eq_PiM[symmetric])
    apply (auto intro!: prob_space_exponential simp: emeasure_distr insert_absorb)
    apply (subst emeasure_distr[OF **])
    subgoal
      using I_countable by (auto simp: pred_def[symmetric])
    apply (subst P'.emeasure_pair_measure_alt)
    subgoal
      using I_countable[of x]
      apply (intro measurable_sets[OF **])
      apply (auto simp: pred_def[symmetric])
      done
    apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator if_split_asm
      simp: space_exponential space_PiM space_pair_measure PiE_iff extensional_def)
    done
  also have " = (+ty. indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y))) ?E y)"
    apply (intro nn_integral_cong_AE)
    using AE_exponential[OF 0 < R x y]
  proof eventually_elim
    fix ty :: real assume "0 < ty"
    have "escape_rate x =
      (+y'. R x y' * indicator {y} y' count_space UNIV) + (+y'. R x y' * indicator (I x - {y}) y' count_space UNIV)"
      unfolding ennreal_escape_rate by (subst nn_integral_add[symmetric]) (auto simp: less_le split: split_indicator intro!: nn_integral_cong)
    also have " = R x y + (+y'. R x y' count_space (I x - {y}))"
      by (auto simp add: nn_integral_count_space_indicator less_le simp del: nn_integral_indicator_singleton
               intro!: arg_cong2[where f="(+)"] nn_integral_cong split: split_indicator)
    finally have "(+y'. R x y' count_space (I x - {y})) = escape_rate x - R x y  R x y  escape_rate x"
      using escape_rate_pos[THEN less_imp_le]
      by (cases "(+y'. R x y' count_space (I x - {y}))")
         (auto simp: add_top ennreal_plus[symmetric] simp del: ennreal_plus)
    then have "integrable (count_space (I x - {y})) (R x)" "(LINT y'|count_space (I x - {y}). R x y') = escape_rate x - R x y"
      by (auto simp: nn_integral_eq_integrable)
    then have "?P' (prod_emb (I x-{y}) ?E (I x-{y}) (ΠE j(I x-{y}). {ty<..})) = exp (- ty * (escape_rate x - R x y))"
      using I_countable 0 < ty by (subst emeasure_PiM_exponential_Ioi_countable) auto
    also have "prod_emb (I x-{y}) ?E (I x-{y}) (ΠE j(I x-{y}). {ty<..}) = {pspace ?P'. y'I x-{y}. ty < p y'}"
      by (simp add: set_eq_iff prod_emb_def space_PiM space_exponential ac_simps Pi_iff)
    finally show "indicator {t..} ty * ?P' {pspace ?P'. y'I x-{y}. ty < p y'} =
      indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y)))"
      by simp
  qed
  also have " = (+ty. ennreal (R x y) * (ennreal (exp (- ty * escape_rate x)) * indicator {max 0 t..} ty) lborel)"
    by (auto simp add: exponential_def exponential_density_def nn_integral_density ennreal_mult[symmetric] exp_add[symmetric] field_simps
                intro!: nn_integral_cong split: split_indicator)
  also have " = (R x y / escape_rate x) * emeasure (exponential (escape_rate x)) {max 0 t..}"
    using escape_rate_pos[of x]
    by (auto simp: exponential_def exponential_density_def emeasure_density nn_integral_cmult[symmetric] ennreal_mult[symmetric]
             split: split_indicator intro!: nn_integral_cong )
  also have " = pmf (J x) y * emeasure (exponential (escape_rate x)) {t..}"
    using AE_exponential[OF escape_rate_pos[of x]]
    by (intro arg_cong2[where f="(*)"] emeasure_eq_AE) (auto simp: J.rep_eq )
  finally show ?thesis
    using assms by (simp add: mult_ac select_first_def)
qed

lemma AE_PAR_least: "AE p in PAR x. yI x. select_first x p y"
proof -
  have D: "disjoint_family_on (λy. {p  space (PAR x). select_first x p y}) (I x)"
    by (auto simp: disjoint_family_on_def dest: select_first_unique)
  have "PAR x {pspace (PAR x). yI x. select_first x p y} =
    PAR x (yI x. {pspace (PAR x). select_first x p y})"
    by (auto intro!: arg_cong2[where f=emeasure])
  also have " = (+y. PAR x {pspace (PAR x). select_first x p y} count_space (I x))"
    using I_countable by (intro emeasure_UN_countable D) auto
  also have " = (+y. PAR x {pspace (PAR x). 0  p y  select_first x p y} count_space (I x))"
  proof (intro nn_integral_cong emeasure_eq_AE, goal_cases)
    case (1 y) with AE_PiM_component[of "I x" "λy. exponential (R x y)" y "(<) 0"] AE_exponential[of "R x y"] show ?case
      by (auto simp: prob_space_exponential)
  qed (insert I_countable, auto)
  also have " = (+y. emeasure (exponential (escape_rate x)) {0 ..} * ennreal (pmf (J x) y) count_space (I x))"
    by (auto simp add: PAR_least intro!: nn_integral_cong)
  also have " = (+y. emeasure (exponential (escape_rate x)) {0 ..} J x)"
    by (auto simp: nn_integral_measure_pmf nn_integral_count_space_indicator ac_simps pmf_eq_0_set_pmf set_pmf_J
             simp del: nn_integral_const intro!: nn_integral_cong split: split_indicator)
  also have " = 1"
    using AE_exponential[of "escape_rate x"]
    by (auto intro!: prob_space.emeasure_eq_1_AE prob_space_exponential simp: escape_rate_pos less_imp_le)
  finally show ?thesis
    using I_countable
    by (subst prob_space.AE_iff_emeasure_eq_1 prob_space_PiM prob_space_exponential)
       (auto intro!: prob_space_PiM prob_space_exponential simp del: Set.bex_simps(6))
qed

lemma K_alt: "K (t, x) = distr (ΠM yI x. exponential (R x y)) S (λp. (t + (INF yI x. p y), The (select_first x p)))" (is "_ = ?R")
proof (rule measure_eqI_generator_eq_countable)
  let ?E = "{ {t ..} × A | (t::real) A. A  - I x  (sI x. A = {s}) }"
  show "Int_stable ?E"
    apply (auto simp: Int_stable_def)
    subgoal for t1 A1 t2 A2
      by (intro exI[of _ "max t1 t2"] exI[of _ "A1  A2"]) auto
    subgoal for t1 t2 y1 y2
      by (intro exI[of _ "max t1 t2"] exI[of _ "{y1}  {y2}"]) auto
    done
  show "sets (K (t, x)) = sigma_sets UNIV ?E"
    unfolding K.sets_K[OF in_space_S] by (subst sets_S_eq) rule
  show "sets ?R = sigma_sets UNIV ?E"
    using sets_S_eq by simp
  show "countable ((λ(t, A). {t ..} × A) ` ( × ({- I x}  (λs. {s}) ` I x)))"
    by (intro countable_image countable_SIGMA countable_rat countable_Un I_countable) auto

   have *: "(+) t -` {t'..}  space (exponential (escape_rate x)) = {t' - t..}" for t'
     by (auto simp: space_exponential)
  { fix X assume "X  ?E"
    then consider
        t' s where "s  I x" "X = {t' ..} × {s}"
      | t' A where "A  - I x" "X = {t' ..} × A"
      by auto
    then show "K (t, x) X = ?R X"
    proof cases
      case 1
      have "AE p in PAR x. (t' - t  p s  select_first x p s) =
              (t'  t + (xI x. p x)  The (select_first x p) = s)"
        using AE_PAR_least by eventually_elim (auto dest: select_first_unique simp: select_first_INF)
      with 1 I_countable show ?thesis
        by (auto simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr emeasure_pmf_single *
          PAR_least[symmetric] intro!: emeasure_eq_AE)
    next
      case 2
      moreover
      then have "emeasure (measure_pmf (J x)) A = 0"
        by (subst AE_iff_measurable[symmetric, where P="λx. x  A"])
           (auto simp: AE_measure_pmf_iff set_pmf_J subset_eq)
      moreover
      have "PAR x ((λp. (t + (p ` (I x)), The (select_first x p))) -` ({t'..} × A)  space (PAR x)) = 0"
        using A  - I x AE_PAR_least[of x] I_countable
        by (subst AE_iff_measurable[symmetric, where P="λp. (t + (p ` (I x)), The (select_first x p))  {t'..} × A"])
           (auto simp del: all_simps(5) simp add: imp_ex imp_conjL subset_eq)
      ultimately show ?thesis
        using I_countable
        by (simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr *)
    qed }

  interpret prob_space "K ts" for ts
    by (rule K.prob_space_K) simp
  show "emeasure (K (t, x)) a  " for a
    using emeasure_finite by simp
qed (insert  Rats_dense_in_real[of "x - 1" x for x], auto, blast intro: less_imp_le)

lemma AE_K: "AE y in K x. fst x < fst y  snd y  J (snd x)"
  unfolding K_def split_beta
  apply (subst exp_esc.AE_pair_iff[symmetric])
  apply measurable
  apply (simp_all add: AE_distr_iff AE_measure_pmf_iff exponential_def AE_density exponential_density_def cong del: AE_cong)
  using AE_lborel_singleton[of 0]
  apply eventually_elim
  apply simp
  done

lemma AE_lim_stream:
  "AE ω in K.lim_stream x. i. snd ((x ## ω) !! i)  DTMC.acc``{snd x}  snd (ω !! i)  J (snd ((x ## ω) !! i))  fst ((x ## ω) !! i) < fst (ω !! i)"
  (is "AE ω in K.lim_stream x. i. ?P ω i")
  unfolding AE_all_countable
proof
  let ?F = "λi x ω. fst ((x ## ω) !! i)" and ?S = "λi x ω. snd ((x ## ω) !! i)"
  fix i show "AE ω in K.lim_stream x. ?P ω i"
  proof (induction i arbitrary: x)
    case 0 with AE_K[of x] show ?case
      by (subst K.AE_lim_stream) (auto simp add: space_pair_measure cong del: AE_cong)
  next
    case (Suc i)
    show ?case
    proof (subst K.AE_lim_stream, goal_cases)
      case 2 show ?case
        using DTMC.countable_reachable
        by (intro measurable_compose_countable_restrict[where f="?S (Suc i) x"])
           (simp_all del: Image_singleton_iff)
    next
      case 3 show ?case
        apply (simp del: AE_conj_iff cong del: AE_cong)
        using AE_K[of x]
        apply eventually_elim
        subgoal premises K_prems for y
          using Suc
          by eventually_elim (insert K_prems, auto intro: converse_rtrancl_into_rtrancl)
        done
    qed (simp add: space_pair_measure)
  qed
qed

lemma measurable_merge_at[measurable]: "(λ(ω, ω'). merge_at ω j ω')  (T M T) M T"
proof (rule measurable_stream_space2)
  define F where "F x n = (case x of (ω::(real × 'a) stream, ω')  merge_at ω j ω') !! n" for x n
  fix n
  have "(λx. F x n)  stream_space S M stream_space S M S"
  proof (induction n)
    case 0 then show ?case
      by (simp add: F_def split_beta' stream.case_eq_if)
  next
    case (Suc n)
    from Suc[measurable]
    have eq: "F x (Suc n) = (case fst x of (t, s) ## ω  if t  j then F (ω, snd x) n else snd x !! Suc n)" for x
      by (auto simp: F_def split: prod.split stream.split)
    show ?case
      unfolding eq stream.case_eq_if by measurable
  qed
  then show "(λx. (case x of (ω, ω')  merge_at ω j ω') !! n)  stream_space S M stream_space S M S"
    unfolding F_def by auto
qed

lemma measurable_trace_at[measurable]: "(λ(s, ω). trace_at s ω j)  (count_space UNIV M T) M count_space UNIV"
  unfolding trace_at_eq by measurable

lemma measurable_trace_at': "(λ((s, j), ω). trace_at s ω j)  ((count_space UNIV M borel) M T) M count_space UNIV"
  unfolding trace_at_eq split_beta' by measurable

lemma K_time_split:
  assumes "t  j" and [measurable]: "f  S M borel"
  shows "(+x. f x * indicator {j <..} (fst x) K (t, s)) = (+x. f x K (j, s)) * exponential (escape_rate s) {j - t <..}"
proof -
  have "(+ y. + x. f (t + x, y) * indicator {j<..} (t + x) exponential (escape_rate s) J s) =
    (+ y. + x. f (t + x, y) * indicator {j - t<..} x exponential (escape_rate s) J s)"
    by (intro nn_integral_cong) (auto split: split_indicator)
  also have " = (+ y. + x. f (t + x, y) uniform_measure (exponential (escape_rate s)) {j-t <..} J s) *
      emeasure (exponential (escape_rate s)) {j - t <..}"
    using t  j escape_rate_pos
    by (subst nn_integral_uniform_measure)
       (auto simp: nn_integral_divide ennreal_divide_times emeasure_exponential_Ioi)
  also have " = (+ y. + x. f (j + x, y) exponential (escape_rate s) J s) *
      emeasure (exponential (escape_rate s)) {j - t <..}"
    using t  j escape_rate_pos by (simp add: uniform_measure_exponential nn_integral_distr)
  finally show ?thesis
    by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr)
qed

lemma K_in_space[simp]: "K x  space (prob_algebra S)"
  by (rule measurable_space [OF K.K]) simp

lemma L_in_space[simp]: "K.lim_stream x  space (prob_algebra T)"
  by (rule measurable_space [OF K.lim_stream]) simp

subsection ‹Markov Chain Property›

lemma lim_time_split:
  "t  j  K.lim_stream (t, s) = do { ω  K.lim_stream (t, s) ; ω'  K.lim_stream (j, trace_at s ω j) ; return T (merge_at ω j ω')}"
    (is "_  _ = ?DO t s")
proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
  case step let ?L = K.lim_stream

  note measurable_compose[OF measurable_prob_algebraD measurable_emeasure_subprob_algebra, measurable (raw)]

  define B' where "B' = (λ(t', s). if t'  j then ?DO t' s else ?L (t', s))"
  show ?case
  proof (intro bexI conjI AE_I2)
    show [measurable]: "B'  S M prob_algebra T"
      unfolding B'_def by measurable
    show "(t s. y = (t, s)  B' y = ?DO t s  t  j)  ?L y = B' y" for y
      by (cases y; cases "fst y  j") (auto simp: B'_def)
    let ?C = "λx. do { ω  ?L x; ω'  ?L (j, trace_at s (x##ω) j); return T (merge_at (x##ω) j ω') }"
    have "?DO t s = do { x  K (t, s); ?C x }"
      apply (subst K.lim_stream_eq[OF in_space_S])
      apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
      apply (subst measurable_cong_sets[OF K.sets_K[OF in_space_S] refl])
      apply measurable
      apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
      apply measurable
      apply (subst bind_cong[OF refl bind_cong[OF refl bind_return[OF measurable_prob_algebraD]]])
      apply measurable
      done
    also have " = K (t, s)  (λy. B' y  (λω. return T (y ## ω)))" (is "?DO' = ?R")
    proof (rule measure_eqI)
      have "sets ?DO' = sets T"
        by (intro sets_bind'[OF K_in_space]) measurable
      moreover have "sets ?R = sets T"
        by (intro sets_bind'[OF K_in_space]) measurable
      ultimately show "sets ?DO' = sets ?R"
        by simp
      fix A assume "A  sets ?DO'"
      then have A[measurable]: "A  T"
        unfolding ‹sets ?DO' = sets T› .
      have "?DO' A = (+x. ?C x A K (t, s))"
        by (subst emeasure_bind_prob_algebra[OF K_in_space]) measurable
      also have " = (+x. ?C x A * indicator {.. j} (fst x) K (t, s)) +
        (+x. ?C x A * indicator {j <..} (fst x) K (t, s))"
        by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
      also have "(+x. ?C x A * indicator {.. j} (fst x) K (t, s)) =
        (+y. emeasure (B' y  (λω. return T (y ## ω))) A * indicator {.. j} (fst y) K (t, s))"
      proof (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
        fix x :: "real × 'a" assume "indicator {..j} (fst x)  (0::ennreal)"
        then have "fst x  j"
          by (auto split: split_indicator_asm)
        then show "?C x = (B' x  (λω. return T (x ## ω)))"
          apply (cases x)
          apply (simp add: B'_def)
          apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
          apply measurable
          apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
          apply measurable
          apply (subst bind_return)
          apply measurable
          done
      qed
      also have "(+x. ?C x A * indicator {j <..} (fst x) K (t, s)) =
        (+y. emeasure (B' y  (λω. return T (y ## ω))) A * indicator {j <..} (fst y) K (t, s))"
      proof -
        have *: "(+) t -` {j<..} = {j - t <..}"
          by auto

        have "(+x. ?C x A * indicator {j <..} (fst x) K (t, s)) =
          (+x. ?L (j, s) A * indicator {j <..} (fst x) K (t, s))"
          by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
             (auto simp: K.sets_lim_stream bind_return'' bind_const' prob_space_K_lim prob_space_imp_subprob_space split: split_indicator_asm)
        also have " = ?L (j, s) A * exponential (escape_rate s) {j - t <..}"
          by (subst nn_integral_cmult) (simp_all add: K_def exp_esc.nn_integral_snd[symmetric] emeasure_distr space_exponential *)
        also have " = (+x. emeasure (?L x  (λω. return T (x ## ω))) A K (j, s)) * exponential (escape_rate s) {j - t <..}"
          by (subst K.lim_stream_eq) (auto simp: emeasure_bind_prob_algebra[OF K_in_space _ A])
        also have " = (+y. emeasure (?L y  (λω. return T (y ## ω))) A * indicator {j <..} (fst y) K (t, s))"
          using t  j by (rule K_time_split[symmetric]) measurable
        also have " = (+y. emeasure (B' y  (λω. return T (y ## ω))) A * indicator {j <..} (fst y) K (t, s))"
          by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
             (auto simp add: B'_def split: split_indicator_asm)
        finally show ?thesis .
      qed
      also have "(+y. emeasure (B' y  (λω. return T (y ## ω))) A * indicator {.. j} (fst y) K (t, s)) +
        (+y. emeasure (B' y  (λω. return T (y ## ω))) A * indicator {j <..} (fst y) K (t, s)) =
        (+y. emeasure (B' y  (λω. return T (y ## ω))) A K (t, s))"
        by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
      also have " = emeasure (K (t, s)  (λy. B' y  (λω. return T (y ## ω)))) A"
        by (rule emeasure_bind_prob_algebra[symmetric, OF K_in_space _ A]) auto
      finally show "?DO' A = emeasure (K (t, s)  (λy. B' y  (λω. return T (y ## ω)))) A" .
    qed
    finally show "?DO t s = K (t, s)  (λy. B' y  (λω. return T (y ## ω)))" .
  qed
qed (simp add: space_pair_measure)

lemma K_eq: "K (t, s) = distr (exponential (escape_rate s) M J s) S (λ(t', s). (t + t', s))"
proof -
  have "distr (exponential (escape_rate s)) borel ((+) t) M distr (J s) (J s) (λx. x) =
    distr (exponential (escape_rate s) M J s) (borel M J s) (λ(x, y). (t + x, y))"
  proof (intro pair_measure_distr)
    interpret prob_space "distr (measure_pmf (J s)) (measure_pmf (J s)) (λx. x)"
      by (intro measure_pmf.prob_space_distr) simp
    show "sigma_finite_measure (distr (measure_pmf (J s)) (measure_pmf (J s)) (λx. x))"
      by unfold_locales
  qed auto
  also have " = distr (exponential (escape_rate s) M J s) S (λ(x, y). (t + x, y))"
    by (intro distr_cong refl sets_pair_measure_cong) simp
  finally show ?thesis
    by (simp add: K_def)
qed

lemma K_shift: "K (t + t', s) = distr (K (t, s)) S (λ(t, s). (t + t', s))"
  unfolding K_eq by (subst distr_distr) (auto simp: comp_def split_beta' ac_simps)

lemma K_not_empty: "space (K x)  {}"
  by (simp add: K_def space_pair_measure split: prod.split)

lemma lim_stream_not_empty: "space (K.lim_stream x)  {}"
  by (simp add: K.space_lim_stream space_pair_measure split: prod.split)

lemma lim_shift: ― ‹Generalize to bijective function on @{const K.lim_stream} invariant on @{const K}
  "K.lim_stream (t + t', s) = distr (K.lim_stream (t, s)) T (smap (λ(t, s). (t + t', s)))"
  (is "_ = ?D t s")
proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
  case step then show ?case
  proof (intro bexI[of _ "λ(t, s). ?D (t - t') s"] conjI)
    show "?D t s = K (t + t', s)  (λy. (case y of (t, s)  ?D (t - t') s)  (λω. return T (y ## ω)))"
      apply (subst K.lim_stream_eq[OF in_space_S])
      apply (subst K_shift)
      apply (subst distr_bind[OF measurable_prob_algebraD K_not_empty])
      apply (measurable; fail)
      apply (measurable; fail)
      apply (subst bind_distr[OF _ measurable_prob_algebraD K_not_empty])
      apply (measurable; fail)
      apply (measurable; fail)
      apply (intro bind_cong refl)
      apply (subst distr_bind[OF measurable_prob_algebraD lim_stream_not_empty])
      apply (measurable; fail)
      apply (measurable; fail)
      apply (simp add: distr_return split_beta)
      apply (subst bind_distr[OF _ measurable_prob_algebraD lim_stream_not_empty])
      apply (measurable; fail)
      apply (measurable; fail)
      apply (simp add: split_beta')
      done
  qed (auto cong: conj_cong intro!: exI[of _ "_ - t'"])
qed simp

lemma lim_0: "K.lim_stream (t, s) = distr (K.lim_stream (0, s)) T (smap (λ(t', s). (t' + t, s)))"
  using lim_shift[of 0 t s] by simp

subsection ‹Explosion time›

definition explosion :: "(real × 'a) stream  ereal"
  where "explosion ω = (SUP i. ereal (fst (ω !! i)))"

lemma ball_less_Suc_eq: "(i<Suc n. P i)  (P 0  (i<n. P (Suc i)))"
  using less_Suc_eq_0_disj by auto

lemma lim_stream_timediff_eq_exponential_1:
  "distr (K.lim_stream ts) (PiM UNIV (λ_. borel))
    (λω i. escape_rate (snd ((ts##ω) !! i)) * (fst (ω !! i) - fst ((ts##ω) !! i))) =
    PiM UNIV (λ_. exponential 1)"
  (is "?D = ?P")
proof (rule measure_eqI_PiM_sequence)
  show "sets ?D = sets (PiM UNIV (λ_. borel))" "sets ?P = sets (PiM UNIV (λ_. borel))"
    by (auto intro!: sets_PiM_cong simp: sets_exponential)
  have [measurable]: "ts  space S"
    by auto
  { interpret prob_space ?D
      by (intro prob_space.prob_space_distr K.prob_space_lim_stream measurable_abs_UNIV) auto
    show "finite_measure ?D"
      by unfold_locales }

  interpret E: prob_space "exponential 1"
    by (rule prob_space_exponential) simp
  interpret P: product_prob_space "λ_. exponential 1" UNIV
    by unfold_locales

  let "distr _ _ (?f ts)" = ?D

  fix A :: "nat  real set" and n :: nat assume A[measurable]: "i. A i  sets borel"
  define n' where "n' = Suc n"
  have "emeasure ?D (prod_emb UNIV (λ_. borel) {..n} (PiE {..n} A)) =
    emeasure (K.lim_stream ts) {ωspace (stream_space S). i<n'. ?f ts ω i  A i}"
    apply (subst emeasure_distr)
      apply (auto intro!: measurable_abs_UNIV arg_cong[where f="emeasure _"])
      apply (auto simp: prod_emb_def K.space_lim_stream space_pair_measure n'_def)
    done
  also have " = (i<n'. emeasure (exponential 1) (A i))"
    using A
  proof (induction n' arbitrary: A ts)
    case 0 then show ?case
      using prob_space.emeasure_space_1[OF prob_space_K_lim]
      by (simp add: K.space_lim_stream space_pair_measure)
  next
    case (Suc n A ts)
    from Suc.prems[measurable]
    have [measurable]: "ts  space S"
      by auto

    have "emeasure (K.lim_stream ts) {ω  space (stream_space S). i<Suc n. ?f ts ω i  A i} =
      (+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) *
        emeasure (K.lim_stream ts') {ω  space (stream_space S). i<n. ?f ts' ω i  A (Suc i)} K ts)"
      apply (subst K.emeasure_lim_stream)
      apply simp
       apply measurable
      apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator
        simp: ball_less_Suc_eq)
      done
    also have " = (+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) K ts) *
      (i<n. emeasure (exponential 1) (A (Suc i)))"
      by (subst Suc.IH) (simp_all add: nn_integral_multc)
    also have "(+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) K ts) =
      (+t. indicator (A 0) (escape_rate (snd ts) * t) exponential (escape_rate (snd ts)))"
      by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr split: prod.split)
    also have " = emeasure (exponential 1) (A 0)"
      using escape_rate_pos[of "snd ts"]
      by (subst exponential_eq_stretch) (simp_all add: nn_integral_distr)
    also have "emeasure (exponential 1) (A 0) * (i<n. emeasure (exponential 1) (A (Suc i))) =
      (i<Suc n. emeasure (exponential 1) (A i))"
      by (rule prod.lessThan_Suc_shift[symmetric])
    finally show ?case .
  qed
  also have " = emeasure ?P (prod_emb UNIV (λ_. borel) {..<n'} (PiE {..<n'} A))"
    using P.emeasure_PiM_emb[of "{..<n'}" A] by (simp add: prod_emb_def space_exponential)
  finally show "emeasure ?D (prod_emb UNIV (λ_. borel) {..n} (PiE {..n} A)) =
    emeasure ?P (prod_emb UNIV (λ_. borel) {..n} (PiE {..n} A))"
    by (simp add: n'_def lessThan_Suc_atMost)
qed

lemma AE_explosion_infty:
  assumes bdd: "bdd_above (range escape_rate)"
  shows "AE ω in K.lim_stream x. explosion ω = "
proof -
  have "escape_rate undefined  (SUP x. escape_rate x)"
    using bdd by (intro cSUP_upper) auto
  then have SUP_escape_pos: "0 < (SUP x. escape_rate x)"
    using escape_rate_pos[of undefined] by simp
  then have SUP_escape_nonneg: "0  (SUP x. escape_rate x)"
    by (rule less_imp_le)

  have [measurable]: "x  space S" by auto
  have "(i. 1::ennreal) = top"
    by (rule sums_unique[symmetric]) (auto simp: sums_def of_nat_tendsto_top_ennreal)
  then have "AE ω in (PiM UNIV (λ_. exponential 1)). (i. ereal (ω i)) = "
    by (intro AE_PiM_exponential_suminf_infty) auto
  then have "AE ω in K.lim_stream x.
    (i. ereal (escape_rate (snd ((x##ω) !! i)) * (fst (ω !! i) - fst ((x##ω) !! i)))) = "
    apply (subst (asm) lim_stream_timediff_eq_exponential_1[symmetric, of x])
    apply (subst (asm) AE_distr_iff)
    apply (auto intro!: measurable_abs_UNIV)
    done
  then show ?thesis
    using AE_lim_stream
  proof eventually_elim
    case (elim ω)
    then have le: "fst ((x##ω) !! n)  fst ((x ## ω) !! m)" if "n  m" for n m
      by (intro lift_Suc_mono_le[OF _ n  m, of "λi. fst ((x ## ω) !! i)"]) (auto intro: less_imp_le)
    have [simp]: "fst x  fst ((x##ω) !! i)" "fst ((x##ω) !! i)  fst (ω !! i)" for i
      using le[of "i" "Suc i"] le[of 0 i] by auto

    have "(i. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i)))) =
      (SUP n. i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i))))"
      by (intro suminf_ereal_eq_SUP) (auto intro!: mult_nonneg_nonneg)
    also have "  (SUP n. (SUP x. escape_rate x) * (ereal (fst ((x ## ω) !! n)) - ereal (fst x)))"
    proof (intro SUP_least SUP_upper2)
      fix n
      have "(i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i)))) 
        (i<n. ereal ((SUP i. escape_rate i) * (fst (ω !! i) - fst ((x ## ω) !! i))))"
        using elim bdd by (intro sum_mono) (auto intro!: cSUP_upper)
      also have " = (SUP i. escape_rate i) * (i<n. fst ((x ## ω) !! Suc i) - fst ((x ## ω) !! i))"
        using elim bdd by (subst sum_ereal) (auto simp: sum_distrib_left)
      also have " = (SUP i. escape_rate i) * (fst ((x ## ω) !! n) - fst x)"
        by (subst sum_lessThan_telescope) simp
      finally show "(i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i))))
          (SUP x. escape_rate x) * (ereal (fst ((x ## ω) !! n)) - ereal (fst x))"
        by simp
    qed simp
    also have " = (SUP x. escape_rate x) * ((SUP n. ereal (fst ((x ## ω) !! n))) - ereal (fst x))"
      using elim SUP_escape_nonneg by (subst SUP_ereal_mult_left) (auto simp: SUP_ereal_minus_left[symmetric])
    also have "(SUP n. ereal (fst ((x ## ω) !! n))) = explosion ω"
      unfolding explosion_def
      apply (intro SUP_eq)
      subgoal for i by (intro bexI[of _ i]) auto
      subgoal for i by (intro bexI[of _ "Suc i"]) auto
      done
    finally show "explosion ω = "
      using elim SUP_escape_pos by (cases "explosion ω") (auto split: if_splits)
  qed
qed

subsection ‹Transition probability $p_t$›

context
begin

declare [[inductive_internals = true]]

inductive trace_in :: "'a set  real  'a  (real × 'a) stream  bool" for S t
where
  "t < t'  s  S  trace_in S t s ((t', s')##ω)"
| "t  t'  trace_in S t s' ω  trace_in S t s ((t', s')##ω)"

end

lemma trace_in_simps[simp]:
  "trace_in ss t s (x##ω) = (if t < fst x then s  ss else trace_in ss t (snd x) ω)"
  by (cases x) (subst trace_in.simps; auto)

lemma trace_in_eq_lfp:
  "trace_in ss t = lfp (λF s. λ(t', s')##ω  if t < t' then s  ss else F s' ω)"
  unfolding trace_in_def by (intro arg_cong[where f=lfp] ext) (auto split: stream.splits)

lemma trace_in_shiftD: "trace_in ss t s ω  trace_in ss (t + t') s (smap (λ(t, s'). (t + t', s')) ω)"
  by (induction rule: trace_in.induct) auto

lemma trace_in_shift[simp]: "trace_in ss t s (smap (λ(t, s'). (t + t', s')) ω)  trace_in ss (t - t') s ω"
  using trace_in_shiftD[of ss t s "smap (λ(t, s'). (t + t', s')) ω" "- t'"]
    trace_in_shiftD[of ss "t - t'" s ω t']
  by (auto simp add: stream.map_comp prod.case_eq_if)

lemma measurable_trace_in':
  "Measurable.pred (borel M count_space UNIV M T) (λ(t, s, ω). trace_in ss t s ω)"
    (is "?M (λ(t, s, ω). trace_in ss t s ω)")
proof -
  let ?F = "λF. λ(t, s, (t', s')##ω)  if t < t' then s  ss else F (t, s', ω)"
  have [measurable]: "Measurable.pred (count_space UNIV) (λx. x  ss)"
    by simp
  have "trace_in ss = (λt s ω. lfp ?F (t, s, ω))"
    unfolding trace_in_def
    apply (subst lfp_arg)
    apply (subst lfp_rolling[where g="λF t s ω. F (t, s, ω)"])
    subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
    subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
    subgoal
      by (intro arg_cong[where f=lfp])
         (auto simp: mono_def le_fun_def split_beta' not_less fun_eq_iff split: stream.splits intro!: arg_cong[where f=lfp])
    done
  then have eq: "(λ(t, s, ω). trace_in ss t s ω) = lfp ?F"
    by simp
  have "sup_continuous ?F"
    by (auto simp: sup_continuous_def fun_eq_iff split: stream.splits)
  then show ?thesis
    unfolding eq
  proof (rule measurable_lfp)
    fix F assume "?M F" then show "?M (?F F)"
      by measurable
  qed
qed

lemma measurable_trace_in[measurable (raw)]:
  assumes [measurable]: "f  M M borel" "g  M M count_space UNIV" "h  M M T"
  shows "Measurable.pred M (λx. trace_in ss (f x) (g x) (h x))"
  using measurable_compose[of "λx. (f x, g x, h x)" M, OF _ measurable_trace_in'[of ss]] by simp

definition p :: "'a  'a  real  real"
where "p s s' t = 𝒫(ω in K.lim_stream (0, s). trace_in {s'} t s ω)"

lemma p[measurable]: "(λ(s, t). p s s' t)  (count_space UNIV M borel) M borel"
proof -
  have *: "(SIGMA x:space (count_space UNIV M borel). {ω  streams (space S). trace_in {s'} (snd x) (fst x) ω}) =
    {xspace ((count_space UNIV M borel) M T). trace_in {s'} (snd (fst x)) (fst (fst x)) (snd x)}"
    by (auto simp: space_pair_measure)

  note measurable_trace_at'[measurable]
  show ?thesis
    unfolding p_def[abs_def] split_beta'
    by (rule measure_measurable_prob_algebra2[where N=T])
       (auto simp: K.space_lim_stream * pred_def[symmetric]
                intro!: pred_count_space_const1 measurable_trace_at'[unfolded split_beta'])
qed

lemma p_nonpos: assumes "t  0" shows "p s s' t = of_bool (s = s')"
proof -
  have "AE ω in K.lim_stream (0, s). trace_in {s'} t s ω = (s = s')"
  proof (subst K.AE_lim_stream)
    show "AE y in K (0, s). AE ω in K.lim_stream y. trace_in {s'} t s (y ## ω) = (s = s')"
      using AE_K
    proof eventually_elim
      fix y :: "real × 'a" assume "fst (0, s) < fst y  snd y  set_pmf (J (snd (0, s)))"
      with t0 show "AE ω in K.lim_stream y. trace_in {s'} t s (y ## ω) = (s = s')"
        by (cases y) auto
    qed
  qed auto
  then have "p s s' t = 𝒫(ω in K.lim_stream (0, s). s = s')"
    unfolding p_def by (intro prob_space.prob_eq_AE K.prob_space_lim_stream) auto
  then show ?thesis
    using prob_space.prob_space[OF K.prob_space_lim_stream] by simp
qed

lemma p_0: "p s s' 0 = of_bool (s = s')"
  using p_nonpos[of 0] by simp

lemma in_sets_T[measurable (raw)]: "Measurable.pred T P  {ω. P ω}  sets T"
  unfolding pred_def by simp

lemma distr_id': "sets M = sets N  distr M N (λx. x) = M"
  by (subst distr_cong[of M M N M _ "λx. x"] ) simp_all

lemma p_nonneg[simp]: "0  p s s' t"
  by (simp add: p_def)

lemma p_le_1[simp]: "p s s' t  1"
  unfolding p_def by (intro prob_space.prob_le_1 K.prob_space_lim_stream) simp

lemma p_eq:
  assumes "0  t"
  shows "p s s'' t = (of_bool (s = s'') + (LINT u:{0..t}|lborel. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
proof -
  have *: "(+) 0 = (λx::real. x)"
    by auto
  interpret L: prob_space "K.lim_stream x" for x
    by (rule K.prob_space_lim_stream) simp
  interpret E: prob_space "exponential (escape_rate s)" for s
    by (intro escape_rate_pos prob_space_exponential)
  have "p s s'' t = emeasure (K.lim_stream (0, s)) {ωspace T. trace_in {s''} t s ω}"
    by (simp add: p_def L.emeasure_eq_measure K.space_lim_stream space_stream_space del: in_space_T)
  also have " = (+y. emeasure (K.lim_stream y) {ωspace T. trace_in {s''} t s (y##ω) } K (0, s))"
    apply (subst K.lim_stream_eq[OF in_space_S])
    apply (subst emeasure_bind_prob_algebra[OF K_in_space])
    apply (measurable; fail)
    apply (measurable; fail)
    apply (subst bind_return_distr'[OF lim_stream_not_empty])
    apply (measurable; fail)
    apply (simp add: emeasure_distr)
    done
  also have " = (+y. indicator {t <..} (fst y) * of_bool (s = s'') + indicator {0<..t} (fst y) * p (snd y) s'' (t - fst y) K (0, s))"
    apply (intro nn_integral_cong_AE)
    using AE_K
    apply eventually_elim
    subgoal for y
      using L.emeasure_space_1
      apply (cases y)
      apply (auto split: split_indicator simp del: in_space_T)
      subgoal for t' s2
        unfolding p_def L.emeasure_eq_measure[symmetric] K.space_lim_stream space_stream_space[symmetric]
        by (subst lim_0) (simp add: emeasure_distr)
      subgoal
        by (auto split: split_indicator cong: rev_conj_cong simp add: K.space_lim_stream space_stream_space simp del: in_space_T)
      done
    done
  also have " = (+u. +s'. indicator {t <..} u * of_bool (s = s'') +
    indicator {0<..t} u * p s' s'' (t - u) J s exponential (escape_rate s))"
    unfolding K_def
    by (simp add: K_def measure_pmf.nn_integral_fst[symmetric] * distr_id' sets_exponential)
  also have " = ennreal (exp (- t * escape_rate s) * of_bool (s = s'')) +
      (+u. indicator {0<..t} u * +s'. p s' s'' (t - u) J s exponential (escape_rate s))"
    using 0t by (simp add: nn_integral_add nn_integral_cmult ennreal_indicator ennreal_mult emeasure_exponential_Ioi escape_rate_pos)
  also have "(+u. indicator {0<..t} u * +s'. p s' s'' (t - u) J s exponential (escape_rate s)) =
      (+u. indicator {0<..t} u *R (LINT s'|J s. p s' s'' (t - u)) exponential (escape_rate s))"
    by (simp add: measure_pmf.integrable_const_bound[of _ 1] nn_integral_eq_integral ennreal_mult ennreal_indicator)
  also have " = (LINT u:{0<..t}|exponential (escape_rate s). (LINT s'|J s. p s' s'' (t - u)))"
    unfolding set_lebesgue_integral_def
    by (intro nn_integral_eq_integral E.integrable_const_bound[of _ 1] AE_I2)
       (auto intro!: mult_le_one measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
  also have " = (LINT u:{0<..t}|lborel. escape_rate s * exp (- escape_rate s * u) * (LINT s'|J s. p s' s'' (t - u)))"
    unfolding exponential_def set_lebesgue_integral_def
    by (subst integral_density)
       (auto simp: ac_simps exponential_density_def fun_eq_iff split: split_indicator
             simp del: integral_mult_right integral_mult_right_zero intro!: arg_cong2[where f="integralL"])
  also have " = (LINT u:{0..t}|lborel. escape_rate s * exp (- escape_rate s * (t - u)) * (LINT s'|J s. p s' s'' u))"
    using AE_lborel_singleton[of 0] AE_lborel_singleton[of t] unfolding set_lebesgue_integral_def
    by (subst lborel_integral_real_affine[where t=t and c="-1"])
       (auto intro!: integral_cong_AE split: split_indicator)
  also have " = exp (- t * escape_rate s) * escape_rate s * (LINT u:{0..t}|lborel. exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))"
    by (simp add: field_simps exp_diff exp_minus)
  finally show "p s s'' t = (of_bool (s = s'') + (LBINT u:{0..t}. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
    unfolding set_lebesgue_integral_def
    by (simp del: ennreal_plus add: ennreal_plus[symmetric] exp_minus field_simps)
qed

lemma continuous_on_p: "continuous_on A (p s s')"
proof -
  interpret E: prob_space "exponential (escape_rate s'')" for s''
    by (intro escape_rate_pos prob_space_exponential)
  have "continuous_on {..0} (p s s')"
    by (simp add: p_nonpos continuous_on_const cong: continuous_on_cong_simp)
  moreover have "continuous_on {0..} (p s s')"
  proof (subst continuous_on_cong[OF refl p_eq])
    let ?I = "λt. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
    show "continuous_on {0..} (λt. (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) / exp (t * escape_rate s))"
    proof (intro continuous_intros continuous_on_LBINT[THEN continuous_on_subset])
      fix t :: real assume t: "0  t"
      then have "0  x  x  t  exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x)  exp (t * escape_rate s) * 1" for x
        by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
      with t show "set_integrable lborel {0..t} ?I"
        using escape_rate_pos[of s] unfolding set_integrable_def
        by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
           (auto simp: field_simps)
    qed auto
  qed simp
  ultimately have "continuous_on ({0..}  {..0}) (p s s')"
    by (intro continuous_on_closed_Un) auto
  also have "{0..}  {..0::real} = UNIV" by auto
  finally show ?thesis
    by (rule continuous_on_subset) simp
qed

lemma p_vector_derivative: ― ‹Backward equation›
  assumes "0  t"
  shows "(p s s' has_vector_derivative (LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t)
    (at t within {0..})"
    (is "(_ has_vector_derivative ?A) _")
proof -
  let ?I = "λt. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
  let ?p = "λt. (of_bool (s = s') + integral {0..t} ?I) * exp (t *R - escape_rate s)"

  { fix t :: real assume "0  t"
    have "p s s' t = (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) * exp (- t * escape_rate s)"
      using p_eq[OF 0  t, of s s'] by (simp add: exp_minus field_simps)
    also have "(LBINT u:{0..t}. ?I u) = integral {0..t} ?I"
    proof (intro set_borel_integral_eq_integral)
      have "0  x  x  t  exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x)  exp (t * escape_rate s) * 1" for x
        by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
      with 0t show "set_integrable lborel {0..t} ?I"
        using escape_rate_pos[of s] unfolding set_integrable_def
        by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
           (auto simp: field_simps)
    qed
    finally have "p s s' t = ?p t"
      by simp }
  note p_eq = this

  have at_eq: "at t within {0..} = at t within {0 .. t + 1}"
    by (intro at_within_nhd[where S="{..< t+1}"]) auto

  have c_I: "continuous_on {0..t + 1} ?I"
    by (intro continuous_intros continuous_on_LINT_pmf[where B=1] continuous_on_p) simp

  show ?thesis
  proof (subst has_vector_derivative_cong_ev)
    show "F u in nhds t. u  {0..}  p s s' u = ?p u" "p s s' t = ?p t"
      using 0t by (simp_all add: p_eq)
    have "(?p has_vector_derivative escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t)) (at t within {0..})"
      unfolding at_eq
      apply (intro refl derivative_eq_intros)
      apply rule
      apply (rule integral_has_vector_derivative[OF c_I])
      apply (simp add: 0  t)
      apply rule
      apply (rule exp_scaleR_has_vector_derivative_right)
      apply (simp add: field_simps exp_minus p_eq 0t split del: split_of_bool)
      done
    also have "escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t) =
        (LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t"
      using escape_rate_pos[of s]
      by (simp add: measure_pmf_eq_density integral_density J.rep_eq field_simps)
    finally show "(?p has_vector_derivative  ?A) (at t within {0..})" .
  qed
qed

coinductive wf_times :: "real  (real × 'a) stream  bool"
where
  "t < t'  wf_times t' ω  wf_times t ((t', s') ## ω)"

lemma wf_times_simp[simp]: "wf_times t (x ## ω)  t < fst x  wf_times (fst x) ω"
  by (cases x) (subst wf_times.simps; simp)

lemma trace_in_merge_at:
  assumes ω': "wf_times t' ω'"
  shows "trace_in ss t x (merge_at ω t' ω') 
    (if t < t' then trace_in ss t x ω else y. trace_in {y} t' x ω  trace_in ss t y ω')"
    (is "?merge  ?cases")
proof safe
  assume ?merge from this ω' show ?cases
  proof (induction ω"merge_at ω t' ω'" arbitrary: ω ω')
    case (1 j s' y ω'') then show ?case
      by (cases ω) (auto split: if_splits)
  next
    case (2 j x ω' s' ω ω'') then show ?case
      by (cases ω) (auto split: if_splits)
  qed
next
  assume ?cases then show ?merge
  proof (split if_split_asm)
    assume "trace_in ss t x ω" "t < t'" from this ω' show ?thesis
    proof induction
      case 1 then show ?case
        by (cases ω') auto
    qed auto
  next
    assume "y. trace_in {y} t' x ω  trace_in ss t y ω'" "¬ t < t'"
    then obtain y where "trace_in {y} t' x ω" "trace_in ss t y ω'" "t'  t"
      by auto
    from this ω' show ?thesis
      by induction auto
  qed
qed

lemma AE_lim_wf_times: "AE ω in K.lim_stream (t, s). wf_times t ω"
  using AE_lim_stream
proof eventually_elim
  fix ω assume *: "i. snd (((t, s) ## ω) !! i)  DTMC.acc `` {snd (t, s)} 
             snd (ω !! i)  J (snd (((t, s) ## ω) !! i)) 
             fst (((t, s) ## ω) !! i) < fst (ω !! i)"
  have "(t ## smap fst ω) !! i < fst (ω !! i)" for i
    using *[THEN spec, of i] by (cases i) auto
  then show "wf_times t ω"
  proof (coinduction arbitrary: t ω)
    case wf_times from this[THEN spec, of 0] this[THEN spec, of "Suc i" for i]  show ?case
      by (cases ω) auto
  qed
qed

lemma wf_times_shiftD: "wf_times t' (smap (λ(t', y). (t' + t, y)) ω)  wf_times (t' - t) ω"
  apply (coinduction arbitrary: t' t ω)
  subgoal for t' t ω
    apply (cases ω; cases "shd ω")
    apply (auto simp: )
    subgoal for ω' j x
      by (rule exI[of _ "j + t"]) auto
    done
  done

lemma wf_times_shift[simp]: "wf_times t' (smap (λ(t', y). (t' + t, y)) ω) = wf_times (t' - t) ω"
  using wf_times_shiftD[of "t' - t" "-t" "smap (λ(t', y). (t' + t, y)) ω"]
  by (auto simp: stream.map_comp stream.case_eq_if prod.case_eq_if wf_times_shiftD)

lemma trace_in_unique: "trace_in {y1} t x ω  trace_in {y2} t x ω  y1 = y2"
  by (induction rule: trace_in.induct) auto

lemma trace_at_eq: "trace_in {z} t x ω  trace_at x ω t = z"
  by (induction rule: trace_in.induct) auto

lemma AE_lim_acc: "AE ω in K.lim_stream (t, x). t z. trace_in {z} t x ω  (x, z)  DTMC.acc"
  using AE_lim_stream
proof (eventually_elim, safe)
  fix t' z ω assume *: "i. snd (((t, x) ## ω) !! i)  DTMC.acc `` {snd (t, x)} 
    snd (ω !! i)  J (snd (((t, x) ## ω) !! i))  fst (((t, x) ## ω) !! i) < fst (ω !! i)"
    and t: "trace_in {z} t' x ω"
  define X where "X = DTMC.acc `` {x}"
  have "(x ## smap snd ω) !! i  X" for i
    using *[THEN spec, of i] by (cases i) (auto simp: X_def)
  from t this have "z  X"
  proof induction
    case (1 j y x ω) with "1.prems"[of 0] show ?case
      by simp
  next
    case (2 j y ω x) with "2.prems"[of "Suc i" for i] show ?case
      by simp
  qed
  then show "(x, z)  DTMC.acc"
    by (simp add: X_def)
qed

lemma p_add:
  assumes "0  t" "0  t'"
  shows "p x y (t + t') = (LINT z|count_space (DTMC.acc``{x}). p x z t * p z y t')"
proof -
  interpret L: prob_space "K.lim_stream xy" for xy
    by (rule K.prob_space_lim_stream) simp
  interpret A: sigma_finite_measure "count_space (DTMC.acc``{x})"
    by (intro sigma_finite_measure_count_space_countable DTMC.countable_acc) simp
  interpret LA: pair_sigma_finite "count_space (DTMC.acc``{x})" "K.lim_stream xy" for xy
    by unfold_locales

  have "p x y (t + t') = (+ ω. +ω'. indicator {ωspace T. trace_in {y} (t + t') x ω} (merge_at ω t ω')
    K.lim_stream (t, trace_at x ω t) K.lim_stream (0, x))"
    unfolding p_def L.emeasure_eq_measure[symmetric]
    apply (subst lim_time_split[OF 0  t])
    apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
    apply (measurable; fail)
    apply (measurable; fail)
    apply (intro nn_integral_cong)
    apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
    apply (measurable; fail)
    apply (measurable; fail)
    apply (simp add: in_space_lim_stream)
    done
  also have " = (+ ω. +ω'. indicator {ωspace T. trace_in {y} (t + t') x ω} (merge_at ω t (smap (λ(t'', s). (t'' + t, s)) ω'))
    K.lim_stream (0, trace_at x ω t) K.lim_stream (0, x))"
    unfolding lim_0[of t] by (subst nn_integral_distr) (measurable; fail)+
  also have " = (+ ω. +ω'. of_bool (zDTMC.acc``{x}. trace_in {z} t x ω  trace_in {y} t' z ω')
    K.lim_stream (0, trace_at x ω t) K.lim_stream (0, x))"
    apply (rule nn_integral_cong_AE)
    using AE_lim_wf_times AE_lim_acc
    apply eventually_elim
    subgoal premises ω for ω
      apply (rule nn_integral_cong_AE)
      using AE_lim_wf_times AE_lim_acc
      apply eventually_elim
      using ω assms
      apply (auto simp add: trace_in_merge_at indicator_eq_1_iff)
      done
    done
  also have " = (+ ω. +ω'. +z. of_bool (trace_in {z} t x ω  trace_in {y} t' z ω')
    count_space (DTMC.acc``{x}) K.lim_stream (0, trace_at x ω t) K.lim_stream (0, x))"
    by (intro nn_integral_cong of_bool_Bex_eq_nn_integral) (auto dest: trace_in_unique)
  also have " = (+ ω. +z. +ω'. of_bool (trace_in {z} t x ω  trace_in {y} t' z ω')
    K.lim_stream (0, trace_at x ω t) count_space (DTMC.acc``{x}) K.lim_stream (0, x))"
    apply (subst LA.Fubini')
    apply (subst measurable_split_conv)
    apply (rule measurable_compose_countable'[OF _ measurable_fst])
    apply (auto simp: DTMC.countable_acc)
    done
  also have " = (+z. + ω. of_bool (trace_in {z} t x ω) * +ω'. of_bool (trace_in {y} t' z ω')
    K.lim_stream (0, z) K.lim_stream (0, x) count_space (DTMC.acc``{x}))"
    apply (subst LA.Fubini')
    apply (subst measurable_split_conv)
    apply (rule measurable_compose_countable'[OF _ measurable_fst])
    apply (rule nn_integral_measurable_subprob_algebra2)
    apply (measurable; fail)
    apply (rule measurable_prob_algebraD)
    apply (auto simp: DTMC.countable_acc trace_at_eq intro!: nn_integral_cong)
    done
  also have " = (+z. (+ ω. of_bool (trace_in {z} t x ω)K.lim_stream (0, x)) *
      (+ω'. of_bool (trace_in {y} t' z ω') K.lim_stream (0, z)) count_space (DTMC.acc``{x}))"
     by (auto intro!: nn_integral_cong simp: nn_integral_multc)
  also have " = (+z. ennreal (p x z t) * ennreal (p z y t') count_space (DTMC.acc``{x}))"
    unfolding p_def L.emeasure_eq_measure[symmetric]
    by (auto intro!: nn_integral_cong arg_cong2[where f="(*)"]
             simp: nn_integral_indicator[symmetric] simp del: nn_integral_indicator )
  finally have "(+z. p x z t * p z y t' count_space (DTMC.acc``{x})) = p x y (t + t')"
    by (simp add: ennreal_mult)
  then show ?thesis
    by (subst (asm) nn_integral_eq_integrable) auto
qed

end

end

Theory Example_A

theory Example_A
  imports "../Classifying_Markov_Chain_States"
begin

section ‹Example A› text_raw ‹\label{ex:A}›

text ‹

We formalize the following Markov chain:

\begin{center}
\begin{tikzpicture}[thick]

  \path [fill, color = gray!30] (0, 0) circle(0.6) ;

  \path [fill, color = gray!30] (1, 1) circle(0.6) ;

  \path [fill, color = gray!30] (4.5, 0.66) ellipse(2 and 1.9) ;

  \node (bot)  at (-1, 0) {} ;

  \node[draw,circle] (A)  at (0, 0) {$A$} ;

  \node[draw,circle] (B)  at (1, 1) {$B$} ;

  \node[draw,circle] (C1) at (3, 0) {$C_1$} ;

  \node[draw,circle] (C2) at (6, 0) {$C_2$} ;

  \node[draw,circle] (C3) at (4.5, 2) {$C_3$} ;

  \path[->, >=latex]
    (bot) edge (A)
    (A)   edge                node [above] {$\frac{1}{2}$} (B)
          edge                node [below] {$\frac{1}{2}$} (C1)
    (B)   edge [loop above]   node [left]  {$\frac{1}{2}$} (B)
          edge [out = 0]      node [above] {$\frac{1}{2}$} (C1)
    (C1)  edge [loop above]   node [above] {$\frac{1}{3}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C2)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
    (C2)  edge [loop right]   node [above] {$\frac{1}{3}$} (C2)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
    (C3)  edge [loop right]   node [above] {$\frac{1}{2}$} (C3)
          edge [bend left=15] node [above] {$\frac{1}{4}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{4}$} (C2) ;

\end{tikzpicture}
\end{center}

First we define the state space as its own type:

›

datatype state = A | B | C1 | C2 | C3

text ‹Now the state space is UNIV :: state set›

lemma UNIV_state: "UNIV = {A, B, C1, C2, C3}"
  using state.nchotomy by auto

instance state :: finite
  by standard (simp add: UNIV_state)

text ‹The transition function tau› is easily defined using the case statement, this allows
us to give a sparse specification as all 0› cases are collected at the end.›

definition tau :: "state  state  real" where
  "tau s t = (case (s, t) of
      (A,  B)   1 / 2 | (A,  C1)  1 / 2
    | (B,  B)   1 / 2 | (B,  C1)  1 / 2
    | (C1, C1)  1 / 3 | (C1, C2)  1 / 3 | (C1, C3)  1 / 3
    | (C2, C1)  1 / 3 | (C2, C2)  1 / 3 | (C2, C3)  1 / 3
    | (C3, C1)  1 / 4 | (C3, C2)  1 / 4 | (C3, C3)  1 / 2
    | _  0)"

lift_definition K :: "state  state pmf" is tau
  by (auto simp: tau_def nn_integral_count_space_finite UNIV_state split: state.split simp del: ennreal_plus)

text ‹We use the finite_pmf›-locale which introduces the point measure tau.M›, and
  provides us with the necessary simplifier setup.›

interpretation A: MC_syntax K .

subsection ‹The essential classs @{term "{C1, C2, C3}"}

context
begin

interpretation pmf_as_function .

lemma A_E_eq:
  "set_pmf (K x) = (case x of A  {B, C1} | B  {B, C1} | _  {C1, C2, C3})"
  using state.nchotomy by transfer (auto simp: tau_def split: prod.split state.split)

lemma A_essential: "A.essential_class {C1, C2, C3}"
  by (rule A.essential_classI2) (auto simp: A_E_eq)

lemma A_aperiodic: "A.aperiodic {C1, C2, C3}"
  unfolding A.aperiodic_def
proof safe
  have eq: "x'. (if x' = C1 then 1 else 0) = indicator {C1} x'" by auto

  show "{C1, C2, C3}  UNIV // A.communicating"
    using A_essential by (simp add: A.essential_class_def)
  then have "A.period {C1, C2, C3} = Gcd (A.period_set C1)"
    by (rule A.period_eq) simp
  also have " = 1"
    by (rule Gcd_nat_eq_one) (simp add: A_E_eq A.period_set_def A.p_Suc' A.p_0 eq measure_pmf_single pmf_positive)
  finally show "A.period {C1, C2, C3} = 1" .
qed

subsection ‹The stationary distribution n›

text ‹Similar to tau› we introduce n› using the finite_pmf›-locale.›

lift_definition n :: "state pmf" is "λC1  0.3 | C2  0.3 | C3  0.4 | _  0"
  by (auto simp: UNIV_state nn_integral_count_space_finite split: state.split)

lemma stationary_distribution_N: "A.stationary_distribution n"
  unfolding A.stationary_distribution_def
  apply (auto intro!: pmf_eqI simp: pmf_bind integral_measure_pmf[of UNIV])
  apply transfer
  apply (auto simp: UNIV_state tau_def split: state.split)
  done

lemma exclusive_N[simp]: "set_pmf n = {C1, C2, C3}"
  using state.nchotomy by transfer (auto split: state.splits)

end

lemma n_is_limit:
  assumes x: "x  {C1, C2, C3}" and y: "y  {C1, C2, C3}"
  shows "(A.p x y)  pmf n y"
  using A.stationary_distribution_imp_p_limit[OF A_aperiodic A_essential _ stationary_distribution_N _ x y]
  by simp

lemma C_is_pos_recurrent: "x  {C1, C2, C3}  A.pos_recurrent x"
  using A.stationary_distributionD(1)[OF A_essential _ stationary_distribution_N] by auto

lemma C_recurrence_time:
  assumes x: "x  {C1, C2, C3}"
  shows "A.U' x x = 1 / pmf n x"
proof -
  from A.stationary_distributionD(2)[OF A_essential _ stationary_distribution_N _]
  have "A.stat {C1, C2, C3} = n" by simp
  with x have "1 / pmf n x = 1 / emeasure (A.stat {C1, C2, C3}) {x}"
    by (simp add: emeasure_pmf_single pmf_positive divide_ennreal ennreal_1[symmetric] del: ennreal_1)
  also have " = A.U' x x"
    unfolding A.stat_def using x
    by (subst emeasure_point_measure_finite) (simp_all add:  A.U'_def)
  finally show ?thesis ..
qed

end

Theory Example_B

theory Example_B
  imports "../Classifying_Markov_Chain_States"
begin

section ‹Example B› text_raw ‹\label{ex:B}›

text ‹

We now formalize the following Markov chain:

\begin{center}
\begin{tikzpicture}[thick]

  \begin{scope} [rotate = 45]
    \path [fill, color = gray!30] (7.5, -6) ellipse(3 and 1) ;
  \end{scope}

  \node (bot2)  at (7, -0.5) {} ;
  \node[draw, circle] (1) at ( 8, -0.5) {$0$} ;
  \node[draw, circle] (2) at ( 9,  0.5) {$1$} ;
  \node[draw, circle] (3) at (10,  1.5) {$2$} ;
  \node (inft) at (10.7, 2.6) {} ;
  \node (infb) at (11,   2) {} ;

  \node (inf1) at (10.5, 2) {} ;
  \node (inf2) at (11.5, 3) {} ;

  \path[->, >=latex]
    (bot2) edge (1)
    (1)    edge [loop below]   node [right] {$\frac{2}{3}$} (1)
           edge [bend left=30] node [above] {$\frac{1}{3}$} (2)
    (2)    edge [bend left=30] node [below] {$\frac{2}{3}$} (1)
           edge [bend left=30] node [above] {$\frac{1}{3}$} (3)
    (3)    edge [bend left=30] node [below] {$\frac{2}{3}$} (2)
           edge [bend left=30] node [above] {} (inft)
    (infb)  edge [bend left=30] node [above] {} (3) ;

  \path (inf1) edge [loosely dotted] (inf2) ;

\end{tikzpicture}
\end{center}

As state space we have the set of natural numbers, the transition function @{term tau} has three
cases:

›

definition K :: "nat  nat pmf" where
  "K x = map_pmf (λTrue  x + 1 | False  x - 1) (bernoulli_pmf (1/3))"

text ‹For the special case when @{term "x = (0::nat)"} we have @{term "x - 1 = (0::nat)"} and hence
@{term "tau 0 0 = 2 / 3"}.›

text ‹We pack this transition function into a discrete Markov kernel.›

text ‹We call the locale of the Markov chain B›, hence all constants and theorems
  from this Markov chain get a B› prefix.›

interpretation B: MC_syntax K .

subsection ‹Enabled, accessible and communicating states›

text ‹For each step the predecessor and the successor are enabled (in the @{term 0} case, the
predecessor is again @{term 0}. Hence every state is accessible from everywhere and every states is
communicating with each other state. Finally we know that the state space is an essential class.›

lemma B_E_eq: "set_pmf (K x) = {x - 1, x + 1}"
  by (auto simp: set_pmf_bernoulli K_def split: bool.split)

lemma B_E_Suc: "Suc x  set_pmf (K x)" "x  set_pmf (K (Suc x))"
  unfolding B_E_eq by auto

lemma B_accessible[intro]: "(i, j)  B.acc"
proof (cases i j rule: linorder_le_cases)
  assume "i  j" then show ?thesis
    by (induct rule: inc_induct) (auto intro: B_E_Suc converse_rtrancl_into_rtrancl)
next
  assume "j  i" then show ?thesis
    by (induct rule: dec_induct) (auto intro: B_E_Suc converse_rtrancl_into_rtrancl)
qed

lemma B_communicating[intro]: "(i, j)  B.communicating"
  by (simp add: B.communicating_def B_accessible)

lemma B_essential: "B.essential_class UNIV"
  by (rule B.essential_classI2) auto

subsection ‹B is aperiodic›

lemma B_aperiodic: "B.aperiodic UNIV"
  unfolding B.aperiodic_def
proof safe
  have eq: "x'. (if x' = 0 then 1 else 0) = indicator {0} x'" by auto

  show "UNIV  UNIV // B.communicating"
    using B_essential by (simp add: B.essential_class_def)
  then have "B.period UNIV = Gcd (B.period_set 0)"
    by (rule B.period_eq) simp
  also have " = 1"
    by (rule Gcd_nat_eq_one) (simp add: B.period_set_def B.p_Suc' B.p_0 eq measure_pmf_single pmf_positive_iff K_def set_pmf_bernoulli UNIV_bool)
  finally show "B.period UNIV = 1" .
qed

subsection ‹The stationary distribution N›

abbreviation N :: "nat pmf" where
  "N  geometric_pmf (1 / 2)"

lemma stationary_distribution_N: "B.stationary_distribution N"
  unfolding B.stationary_distribution_def
proof (rule pmf_eqI)
  fix a show "pmf N a = pmf (bind_pmf N K) a"
    apply (simp add: pmf_bind K_def map_pmf_def)
    apply (subst integral_measure_pmf[of "{a - 1, a + 1}"])
    apply (auto split: split_indicator_asm nat.splits simp: minus_nat.diff_Suc)
    done
qed

subsection ‹Limit behavior and recurrence times›

lemma limit: "(B.p i j)  (1/2)^Suc j"
proof -
  have "B.p i j  pmf N j"
    by (rule B.stationary_distribution_imp_p_limit[OF B_aperiodic B_essential _ stationary_distribution_N])
       auto
  then show ?thesis
    by (simp add: ac_simps)
qed

lemma pos_recurrent: "B.pos_recurrent i"
  using B.stationary_distributionD(1)[OF B_essential _ stationary_distribution_N _] by auto

lemma recurrence_time: "B.U' i i = 2^Suc i"
proof -
  have "B.stat UNIV = N"
    using B.stationary_distributionD(2)[OF B_essential _ stationary_distribution_N _] by simp
  then have "2^Suc i = 1 / emeasure (B.stat UNIV) {i}"
    apply (simp add: field_simps emeasure_pmf_single pmf_positive)
    apply (subst divide_ennreal[symmetric])
    apply (auto simp: ennreal_mult ennreal_power[symmetric])
    done
  also have " = B.U' i i"
    unfolding B.stat_def
    by (subst emeasure_point_measure_finite2)
       (simp_all add: B.U'_def)
  finally show ?thesis
    by simp
qed

end

Theory PCTL

(* Author: Johannes Hölzl <hoelzl@in.tum.de>
   Author: Tobias Nipkow <nipkow@in.tum.de> *)
theory PCTL
imports
  "../Discrete_Time_Markov_Chain"
  "Gauss-Jordan-Elim-Fun.Gauss_Jordan_Elim_Fun"
  "HOL-Library.While_Combinator"
  "HOL-Library.Monad_Syntax"
begin

section ‹Adapt Gauss-Jordan elimination to DTMCs›

locale Finite_DTMC =
  fixes K :: "'s  's pmf" and S :: "'s set" and ρ :: "'s  real" and ι :: "'s  's  real"
  assumes ι_nonneg[simp]: "s t. 0  ι s t" and ρ_nonneg[simp]: "s. 0  ρ s"
  assumes measurable_ι: "(λ(a, b). ι a b)  borel_measurable (count_space UNIV M count_space UNIV)"
  assumes finite_S[simp]: "finite S" and S_not_empty: "S  {}"
  assumes E_closed: "(sS. set_pmf (K s))  S"
begin

lemma measurable_ι'[measurable (raw)]:
  "f  measurable M (count_space UNIV)  g  measurable M (count_space UNIV) 
    (λx. ι (f x) (g x))  borel_measurable M"
  using measurable_compose[OF _ measurable_ι, of "λx. (f x, g x)" M] by simp

lemma measurable_ρ[measurable]: "ρ  borel_measurable (count_space UNIV)"
  by simp

sublocale R?: MC_with_rewards K ι ρ
  by standard (auto intro: ι_nonneg ρ_nonneg)

lemma single_l:
  fixes s and x :: real assumes "s  S"
  shows "(s'S. (if s' = s then 1 else 0) * l s') = x  l s = x"
  by (simp add: assms if_distrib [of "λx. x * a" for a] cong: if_cong)

definition "order = (SOME f. bij_betw f {..< card S} S)"

lemma
  shows bij_order[simp]: "bij_betw order {..< card S} S"
    and inj_order[simp]: "inj_on order {..<card S}"
    and image_order[simp]: "order ` {..<card S} = S"
    and order_S[simp, intro]: "i. i < card S  order i  S"
proof -
  from finite_same_card_bij[OF _ finite_S] show "bij_betw order {..< card S} S"
    unfolding order_def by (rule someI_ex) auto
  then show "inj_on order {..<card S}" "order ` {..<card S} = S"
    unfolding bij_betw_def by auto
  then show "i. i < card S  order i  S"
    by auto
qed

lemma order_Ex:
  assumes "s  S" obtains i where "i < card S" "s = order i"
proof -
  from s  S have "s  order ` {..<card S}"
    by simp
  with that show thesis
    by (auto simp del: image_order)
qed

definition "iorder = the_inv_into {..<card S} order"

lemma bij_iorder: "bij_betw iorder S {..<card S}"
  unfolding iorder_def by (rule bij_betw_the_inv_into bij_order)+

lemma iorder_image_eq: "iorder ` S = {..<card S}"
  and inj_iorder: "inj_on iorder S"
  using bij_iorder  unfolding bij_betw_def by auto

lemma order_iorder: "s. s  S  order (iorder s) = s"
  unfolding iorder_def using bij_order
  by (intro f_the_inv_into_f) (auto simp: bij_betw_def)

definition gauss_jordan' :: "('s  's  real)  ('s  real)  ('s  real) option" where
  "gauss_jordan' M a = do {
     let M' = (λi j. if j = card S then a (order i) else M (order i) (order j)) ;
     sol  gauss_jordan M' (card S) ;
     Some (λi. sol (iorder i) (card S))
  }"

lemma gauss_jordan'_correct:
  assumes "gauss_jordan' M a = Some f"
  shows "sS. (s'S. M s s' * f s') = a s"
proof -
  note ‹gauss_jordan' M a = Some f
  moreover define M' where "M' = (λi j. if j = card S then
    a (order i) else M (order i) (order j))"
  ultimately obtain sol where sol: "gauss_jordan M' (card S) = Some sol"
    and f: "f = (λi. sol (iorder i) (card S))"
    by (auto simp: gauss_jordan'_def Let_def split: bind_split_asm)

  from gauss_jordan_correct[OF sol]
  have "i{..<card S}. (j<card S. M (order i) (order j) * sol j (card S)) = a (order i)"
    unfolding solution_def M'_def by (simp add: atLeast0LessThan)
  then show ?thesis
    unfolding iorder_image_eq[symmetric] f using inj_iorder
    by (subst (asm) sum.reindex) (auto simp: order_iorder)
qed

lemma gauss_jordan'_complete:
  assumes exists: "sS. (s'S. M s s' * x s') = a s"
  assumes unique: "y. sS. (s'S. M s s' * y s') = a s  sS. y s = x s"
  shows "y. gauss_jordan' M a = Some y"
proof -
  define M' where "M' = (λi j. if j = card S then
    a (order i) else M (order i) (order j))"

  { fix x
    have iorder_neq_card_S: "s. s  S  iorder s  card S"
      using iorder_image_eq by (auto simp: set_eq_iff less_le)
    have "solution2 M' (card S) (card S) x 
      (s{..<card S}. (s'{..<card S}. M' s s' * x s') = M' s (card S))"
      unfolding solution2_def by (auto simp: atLeast0LessThan)
    also have "  (sS. (s'S. M s s' * x (iorder s')) = a s)"
      unfolding iorder_image_eq[symmetric] M'_def
      using inj_iorder iorder_neq_card_S
      by (simp add: sum.reindex order_iorder)
    finally have "solution2 M' (card S) (card S) x 
      (sS. (s'S. M s s' * x (iorder s')) = a s)" . }
  note sol2_eq = this
  have "usolution M' (card S) (card S) (λi. x (order i))"
    unfolding usolution_def
  proof safe
    from exists show "solution2 M' (card S) (card S) (λi. x (order i))"
      by (simp add: sol2_eq order_iorder)
  next
    fix y j assume y: "solution2 M' (card S) (card S) y" and "j < card S"
    then have "sS. (s'S. M s s' * y (iorder s')) = a s"
      by (simp add: sol2_eq)
    from unique[OF this]
    have "i{..<card S}. y i = x (order i)"
      unfolding iorder_image_eq[symmetric]
      by (simp add: order_iorder)
    with j < card S show "y j = x (order j)" by simp
  qed
  from gauss_jordan_complete[OF _ this]
  show ?thesis
    by (auto simp: gauss_jordan'_def simp: M'_def)
qed

end

section ‹pCTL model checking›

subsection ‹Syntax›

datatype realrel = LessEqual | Less | Greater | GreaterEqual | Equal

datatype 's sform = "true"
                  | "Label" "'s set"
                  | "Neg" "'s sform"
                  | "And" "'s sform" "'s sform"
                  | "Prob" "realrel" "real" "'s pform"
                  | "Exp" "realrel" "real" "'s eform"
     and 's pform = "X" "'s sform"
                  | "U" "nat" "'s sform" "'s sform"
                  | "UInfinity" "'s sform" "'s sform" ("U")
     and 's eform = "Cumm" "nat" ("C")
                  | "State" "nat" ("I=")
                  | "Future" "'s sform"

primrec bound_until where
  "bound_until 0 φ ψ = ψ"
| "bound_until (Suc n) φ ψ = ψ or (φ aand nxt (bound_until n φ ψ))"

lemma measurable_bound_until[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) φ" "Measurable.pred (stream_space M) ψ"
  shows "Measurable.pred (stream_space M) (bound_until n φ ψ)"
  by (induct n) simp_all

subsection ‹Semantics›

primrec inrealrel :: "realrel  'a  ('a::linorder)  bool" where
"inrealrel LessEqual r q     q  r" |
"inrealrel Less r q          q < r" |
"inrealrel Greater r q       q > r" |
"inrealrel GreaterEqual r q  q  r" |
"inrealrel Equal r q         q = r"

context Finite_DTMC
begin

abbreviation "prob s P  measure (T s) {xspace (T s). P x}"
abbreviation "E s  set_pmf (K s)"

primrec svalid :: "'s sform  's set"
and pvalid :: "'s pform  's stream  bool"
and reward :: "'s eform  's stream  ennreal" where
"svalid true           = S" |
"svalid (Label L)      = {s  S. s  L}" |
"svalid (Neg F)        = S - svalid F" |
"svalid (And F1 F2)    = svalid F1  svalid F2" |
"svalid (Prob rel r F) = {s  S. inrealrel rel r 𝒫(ω in T s. pvalid F (s ## ω)) }" |
"svalid (Exp rel r F)  = {s  S. inrealrel rel (ennreal r) (+ ω. reward F (s ## ω) T s) }" |

"pvalid (X F)        = nxt (HLD (svalid F))" |
"pvalid (U k F1 F2)  = bound_until k (HLD (svalid F1)) (HLD (svalid F2))" |
"pvalid (U F1 F2)   = HLD (svalid F1) suntil HLD (svalid F2)" |

"reward (C k)         = (λω. (i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))))" |
"reward (I= k)         = (λω. ρ (ω !! k))" |
"reward (Future F)     = (λω. if ev (HLD (svalid F)) ω then reward_until (svalid F) (shd ω) (stl ω) else )"

lemma svalid_subset_S: "svalid F  S"
  by (induct F) auto

lemma finite_svalid[simp, intro]: "finite (svalid F)"
  using svalid_subset_S finite_S by (blast intro: finite_subset)

lemma svalid_sets[measurable]: "svalid F  sets (count_space S)"
  using svalid_subset_S by auto

lemma pvalid_sets[measurable]: "Measurable.pred R.S (pvalid F)"
  by (cases F) (auto intro!: svalid_sets)

lemma reward_measurable[measurable]: "reward F  borel_measurable R.S"
  by (cases F) auto

subsection ‹Implementation of Sat›

subsubsection Prob0›

definition Prob0 where
  "Prob0 Φ Ψ = S - while (λR. sΦ. R  E s  {}  s  R) (λR. R  {sΦ. R  E s  {}}) Ψ"

lemma Prob0_subset_S: "Prob0 Φ Ψ  S"
  unfolding Prob0_def by auto

lemma Prob0_iff_reachable:
  assumes "Φ  S" "Ψ  S"
  shows "Prob0 Φ Ψ = {s  S. ((SIGMA x:Φ. E x)* `` {s})  Ψ = {}}" (is "_ = ?U")
  unfolding Prob0_def
proof (intro while_rule[where Q="λR. S - R = ?U" and P="λR. Ψ  R  R  S - ?U"] conjI)
  show "wf {(B, A). A  B  B  S}"
    by (rule wf_bounded_set[where ub="λ_. S" and f="λx. x"]) auto
  show "Ψ  S - ?U"
    using assms by auto

  let  = "λR. {sΦ. R  E s  {}}"
  { fix R assume R: "Ψ  R  R  S - ?U" and "sΦ. R  E s  {}  s  R"
    with assms show "(R   R, R)  {(B, A). A  B  B  S}" "Ψ  R   R"
      by auto

    { fix s s' assume s: "s  Φ" "s'  R" "s'  E s" and r: "(Sigma Φ E)* `` {s}  Ψ = {}"
      with R have "(s, s')  (Sigma Φ E)*" "s'  Φ - Ψ"
        by (auto elim: converse_rtranclE)
      moreover with s'  R R obtain s'' where "(s', s'')  (Sigma Φ E)*" "s''  Ψ"
        by auto
      ultimately have "(s, s'')  (Sigma Φ E)*" "s''  Ψ"
        by auto
      with r have False
        by auto }
    with Φ  S R show "R   R  S - ?U" by auto }

  { fix R assume R: "Ψ  R  R  S - ?U" and dR: "¬ (sΦ. R  E s  {}  s  R)"
    { fix s t assume s: "s  S - R"
      assume s_t: "(s, t)  (Sigma Φ E)*" then have "t  S - R"
      proof induct
        case (step t u) with R dR E_closed show ?case
          by auto
      qed fact
      then have "t  Ψ"
        using R by auto }
    with R show "S - R = ?U"
      by auto }
qed rule

lemma Prob0_iff:
  assumes "Φ  S" "Ψ  S"
  shows "Prob0 Φ Ψ = {sS. AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)}" (is "_ = ?U")
  unfolding Prob0_iff_reachable[OF assms]
proof (intro Collect_cong conj_cong refl iffI)
  fix s assume s: "s  S" "(Sigma Φ E)* `` {s}  Ψ = {}"
  { fix ω assume "(HLD Φ suntil HLD Ψ) ω" "enabled (shd ω) (stl ω)" "(Sigma Φ E)* `` {shd ω}  Ψ = {}"
    from this have False
    proof induction
      case (step ω)
      moreover
      then have "(shd ω, shd (stl ω))  (Sigma Φ E)*"
        by (auto simp: enabled.simps[of _ "stl ω"] HLD_iff)
      then have "(Sigma Φ E)* `` {shd (stl ω)}  (Sigma Φ E)* `` {shd ω}"
        by auto
      ultimately show ?case
        by (auto simp add: enabled.simps[of _ "stl ω"])
    qed (auto simp: HLD_iff) }
  from s this[of "s ## ω" for ω] show "AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)"
    using AE_T_enabled[of s] by auto
next
  fix s assume s: "AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)"
  { fix t assume "(s, t)  (Sigma Φ E)*" from this s have "t  Ψ"
    proof (induction rule: converse_rtrancl_induct)
      case (step s u) then show ?case
        by (simp add: AE_T_iff[where x=s] suntil_Stream[of _ _ s])
    qed (simp add: suntil_Stream) }
  then show "(Sigma Φ E)* `` {s}  Ψ = {}"
    by auto
qed

lemma E_rtrancl_closed:
  assumes "s  S" "(s, t)  (SIGMA x:A. B x)*" "x. x  A  B x  E x" shows "t  S"
  using assms(2,3,1) E_closed by induction force+

subsubsection Prob1›

definition Prob1 where
  "Prob1 Y Φ Ψ = Prob0 (Φ - Ψ) Y"

lemma Prob1_iff:
  assumes "Φ  S" "Ψ  S"
  shows "Prob1 (Prob0 Φ Ψ) Φ Ψ = {sS. AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)}"
    (is "Prob1 ?P0 _ _ = {sS. ?pU s}")
proof -
  note P0 = Prob0_iff_reachable[OF assms]
  have *: "Φ - Ψ  S" "?P0  S"
    using P0 assms by auto

  have P0_subset: "S - Φ - Ψ  ?P0"
    unfolding P0 by (auto elim: converse_rtranclE)

  have "Prob1 ?P0 Φ Ψ = {s  S. (Sigma (Φ - Ψ) E)* `` {s}  ?P0 = {}}"
    unfolding Prob0_iff_reachable[OF *] Prob1_def ..
  also have " = {sS. AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)}"
  proof (intro Collect_cong conj_cong refl iffI)
    fix s assume s: "s  S" "(Sigma (Φ - Ψ) E)* `` {s}  ?P0 = {}"
    then have "s  ?P0"
      by auto
    then have "s  Φ - Ψ  s  Ψ"
      using P0_subset s  S by auto
    moreover
    { assume "s  Φ - Ψ"
      have "AE ω in T s. ev (HLD (Ψ  ?P0)) ω"
      proof (rule AE_T_ev_HLD)
        fix t assume s_t: "(s, t)  acc_on (- (Ψ  ?P0))"
        from s  S s_t have "t  S"
          by (rule E_rtrancl_closed) auto

        show "t'Ψ  ?P0. (t, t')  acc"
        proof cases
          assume "t  ?P0" then show ?thesis by auto
        next
          assume "t  ?P0"
          with tS obtain s where t_s: "(t, s)  (SIGMA x:Φ. E x)*" and "s  Ψ"
            unfolding P0 by auto
          from t_s have "(t, s)  acc"
            by (rule rev_subsetD) (intro rtrancl_mono Sigma_mono, auto)
          with s  Ψ show ?thesis by auto
        qed
      next
        have "acc_on (- (Ψ  ?P0)) `` {s}  S"
          using s  S by (auto intro: E_rtrancl_closed)
        then show "finite (acc_on (- (Ψ  ?P0)) `` {s})"
          using finite_S by (auto dest: finite_subset)
      qed
      then have "AE ω in T s. (HLD Φ suntil HLD Ψ) ω"
        using AE_T_enabled
      proof eventually_elim
        fix ω assume "ev (HLD (Ψ  ?P0)) ω" "enabled s ω"
        from this s s  Φ - Ψ show "(HLD Φ suntil HLD Ψ) ω"
        proof (induction arbitrary: s)
          case (base ω) then show ?case
            by (auto simp: HLD_iff enabled.simps[of s] intro: suntil.intros)
        next
          case (step ω)
          then have "(s, shd ω)  (Sigma (Φ - Ψ) E)"
            by (auto simp: enabled.simps[of s])
          then have *: "(Sigma (Φ - Ψ) E)* `` {shd ω}  ?P0 = {}"
            using step.prems by (auto intro: converse_rtrancl_into_rtrancl)
          then have "shd ω  Φ - Ψ  shd ω  Ψ" "shd ω  S"
            using P0_subset step.prems(1,2) E_closed by (auto simp add: enabled.simps[of s])
          then show ?case
            using step.prems(1) step.IH[OF _ _ *] ‹shd ω  S
            by (auto simp add: suntil.simps[of _ _ ω] HLD_iff[abs_def] enabled.simps[of s ω])
        qed
      qed }
    ultimately show "AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)"
      by (cases "s  Φ - Ψ") (auto simp add: suntil_Stream)
  next
    fix s assume s: "s  S" "AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)"
    { fix t assume "(s, t)  (SIGMA s:Φ-Ψ. E s)*"
      from this s  S have "(AE ω in T t. (HLD Φ suntil HLD Ψ) (t ## ω))  t  S"
      proof induction
        case (step t u) with E_closed show ?case
          by (auto simp add: AE_T_iff[of _ t] suntil_Stream)
      qed (insert s, auto)
      then have "t  ?P0"
        unfolding Prob0_iff[OF assms] by (auto dest: T.AE_contr) }
    then show "(Sigma (Φ - Ψ) E)* `` {s}  Prob0 Φ Ψ = {}"
      by auto
  qed
  finally show ?thesis .
qed

subsubsection ProbU›,  ExpCumm›, and ExpState›

abbreviation "τ s t  pmf (K s) t"

fun ProbU :: "'s  nat  's set  's set  real" where
"ProbU q 0 S1 S2       = (if q  S2 then 1 else 0)" |
"ProbU q (Suc k) S1 S2 =
  (if q  S1 - S2 then (q'S. τ q q' * ProbU q' k S1 S2)
                  else if q  S2 then 1 else 0)"

fun ExpCumm :: "'s  nat  ennreal" where
"ExpCumm s 0       = 0" |
"ExpCumm s (Suc k) = ρ s + (s'S. τ s s' * (ι s s' + ExpCumm s' k))"

fun ExpState :: "'s  nat  ennreal" where
"ExpState s 0       = ρ s" |
"ExpState s (Suc k) = (s'S. τ s s' * ExpState s' k)"

subsubsection LES›

definition LES :: "'s set  's  's  real" where
  "LES F r c =
       (if r  F then (if c = r then 1 else 0)
                 else (if c = r then τ r c - 1 else τ r c ))"


subsubsection ProbUinfty›, compute unbounded until›

definition ProbUinfty :: "'s set  's set  ('s  real) option" where
  "ProbUinfty S1 S2 = gauss_jordan' (LES (Prob0 S1 S2  S2))
                                    (λi. if i  S2 then 1 else 0)"

subsubsection ExpFuture›, compute unbounded reward›

definition ExpFuture :: "'s set  ('s  ennreal) option" where
  "ExpFuture F = do {
      let N = Prob0 S F ;
      let Y = Prob1 N S F ;
      sol  gauss_jordan' (LES (S - Y  F))
        (λi. if i  Y  i  F then - ρ i - (s'S. τ i s' * ι i s') else 0) ;
      Some (λs. if s  Y then ennreal (sol s) else )
    }"

subsubsection Sat›

fun Sat :: "'s sform  's set option" where
"Sat true                   = Some S" |
"Sat (Label L)              = Some {s  S. s  L}" |
"Sat (Neg F)                = do { F  Sat F ; Some (S - F) }" |
"Sat (And F1 F2)            = do { F1  Sat F1 ; F2  Sat F2 ; Some (F1  F2) }" |

"Sat (Prob rel r (X F))        = do { F  Sat F ; Some {q  S. inrealrel rel r (q'F. τ q q')} }" |
"Sat (Prob rel r (U k F1 F2))  = do { F1  Sat F1 ; F2  Sat F2 ; Some {q  S. inrealrel rel r (ProbU q k F1 F2) } }" |
"Sat (Prob rel r (U F1 F2))   = do { F1  Sat F1 ; F2  Sat F2 ; P  ProbUinfty F1 F2 ; Some {q  S. inrealrel rel r (P q) } }" |

"Sat (Exp rel r (Cumm k))      = Some {s  S. inrealrel rel r (ExpCumm s k) }" |
"Sat (Exp rel r (State k))     = Some {s  S. inrealrel rel r (ExpState s k) }" |
"Sat (Exp rel r (Future F))    = do { F  Sat F ; E  ExpFuture F ; Some {q  S. inrealrel rel (ennreal r) (E q) } }"


lemma prob_sum:
  "s  S  Measurable.pred R.S P  𝒫(ω in T s. P ω) = (tS. τ s t * 𝒫(ω in T t. P (t ## ω)))"
  unfolding prob_T using E_closed by (subst integral_measure_pmf[OF finite_S]) (auto simp: mult.commute)

lemma nn_integral_eq_sum:
  "s  S  f  borel_measurable R.S  (+x. f x T s) = (tS. τ s t * (+x. f (t ## x) T t))"
  unfolding nn_integral_T using E_closed
  by (subst nn_integral_measure_pmf_support[OF finite_S])
     (auto simp: mult.commute)

lemma T_space[simp]: "measure (T s) (space R.S) = 1"
  using T.prob_space by simp

lemma emeasure_T_space[simp]: "emeasure (T s) (space R.S) = 1"
  using T.emeasure_space_1 by simp

lemma τ_distr[simp]: "s  S  (tS. τ s t) = 1"
  using prob_sum[of s "λ_. True"] by simp

lemma ProbU:
  "q  S  ProbU q k (svalid F1) (svalid F2) = 𝒫(ω in T q. pvalid (U k F1 F2) (q ## ω))"
proof (induct k arbitrary: q)
  case 0 with T.prob_space show ?case by simp
next
  case (Suc k)

  have "𝒫(ω in T q. pvalid (U (Suc k) F1 F2) (q ## ω)) =
    (if q  svalid F2 then 1 else if q  svalid F1 then
      tS. τ q t * 𝒫(ω in T t. pvalid (U k F1 F2) (t ## ω)) else 0)"
    using q  S by (subst prob_sum) simp_all
  also have " = ProbU q (Suc k) (svalid F1) (svalid F2)"
    using Suc by simp
  finally show ?case ..
qed

lemma Prob0_imp_not_Psi:
  assumes "Φ  S" "Ψ  S" "s  Prob0 Φ Ψ" shows "s  Ψ"
proof -
  have "s  S" using s  Prob0 Φ Ψ Prob0_subset_S by auto
  with assms show ?thesis by (auto simp add: Prob0_iff suntil_Stream)
qed

lemma Psi_imp_not_Prob0:
  assumes "Φ  S" "Ψ  S" shows "s  Ψ  s  Prob0 Φ Ψ"
  using Prob0_imp_not_Psi[OF assms] by metis

subsubsection ‹Finite expected reward›

abbreviation "s0  SOME s. s  S"

lemma s0_in_S: "s0  S"
  using S_not_empty by (auto intro!: someI_ex[of "λx. x  S"])

lemma nn_integral_reward_finite:
  assumes "s  S"
  assumes until: "AE ω in T s. (HLD S suntil HLD (svalid F)) (s ## ω)"
  shows "(+ ω. reward (Future F) (s ## ω) T s)  "
proof -
  have "(+ ω. reward (Future F) (s ## ω) T s) = (+ ω. reward_until (svalid F) s ω T s)"
    using until by (auto intro!: nn_integral_cong_AE ev_suntil)
  also have "  "
  proof cases
    assume "s  svalid F"
    show ?thesis
    proof (rule nn_integral_reward_until_finite)
      have "acc `` {s}  S"
        using E_rtrancl_closed[of s _ _ E] s  S by auto
      then show "finite (acc `` {s})"
        using finite_S by (auto dest: finite_subset)
      show "AE ω in T s. (ev (HLD (svalid F))) ω"
        using until by (auto simp add: suntil_Stream s  svalid F intro: ev_suntil)
    qed auto
  qed simp
  finally show ?thesis .
qed

lemma unique:
  assumes in_S: "Φ  S" "Ψ  S" "N  S" "Prob0 Φ Ψ  N" "Ψ  N"
  assumes l1: "s. s  S  s  N  l1 s - c s = (s'S. τ s s' * l1 s')"
  assumes l2: "s. s  S  s  N  l2 s - c s = (s'S. τ s s' * l2 s')"
  assumes eq: "s. s  N  l1 s = l2 s"
  shows "sS. l1 s = l2 s"
proof
  fix s assume "s  S"
  show "l1 s = l2 s"
  proof cases
    assume "s  N" then show ?thesis
      by (rule eq)
  next
    assume "s  N"
    show ?thesis
    proof (rule unique_les[of _ "S - N" K N])
      show "finite ((λx. l1 x - l2 x) ` (S - N  N))" "(xS - N. E x)  S - N  N"
        using E_closed finite_S N  S by (auto dest: finite_subset)
      show "s. s  N  l1 s = l2 s" by fact
      { fix s assume "s  S - N" with E_closed finite_S show "integrable (K s) l1" "integrable (K s) l2"
          by (auto intro!: integrable_measure_pmf_finite dest: finite_subset)
        obtain t where "(t  Ψ  (s, t)  (Sigma Φ E)*)  s  N"
          using s  S - N in_S(4) unfolding Prob0_iff_reachable[OF in_S(1,2)] by auto
        moreover have "(Sigma Φ E)*  acc"
          by (intro rtrancl_mono Sigma_mono) auto
        ultimately show "tN. (s, t)  acc"
          using Ψ  N by auto
        show "l1 s = integralL (K s) l1 + c s"
          using E_closed l1 s  S - N
          by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps)
        show "l2 s = integralL (K s) l2 + c s"
          using E_closed l2 s  S - N
          by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps) }
    qed (insert s   N s  S, auto)
  qed
qed

lemma uniqueness_of_ProbU:
  assumes sol:
    "sS. (s'S. LES (Prob0 (svalid F1) (svalid F2)  svalid F2) s s' * l s') =
      (if s  svalid F2 then 1 else 0)"
  shows "sS. l s = 𝒫(ω in T s. pvalid (U F1 F2) (s ## ω))"
proof (rule unique)
  show "svalid F1  S" "svalid F2  S"
    "Prob0 (svalid F1) (svalid F2)  Prob0 (svalid F1) (svalid F2)  svalid F2"
    "svalid F2  Prob0 (svalid F1) (svalid F2)  svalid F2"
    "Prob0 (svalid F1) (svalid F2)  svalid F2  S"
    using svalid_subset_S by (auto simp: Prob0_def)
next
  fix s assume s: "s  S" "s  Prob0 (svalid F1) (svalid F2)  svalid F2"
  have "(s'S. (if s' = s then τ s s' - 1 else τ s s') * l s') =
    (s'S. τ s s' * l s' - (if s' = s then 1 else 0) * l s')"
    by (auto intro!: sum.cong simp: field_simps)
  also have " = (s'S. τ s s' * l s') - l s"
    using s  S by (simp add: sum_subtractf single_l)
  finally show "l s - 0 = (s'S. τ s s' * l s')"
    using sol[THEN bspec, of s] s by (simp add: LES_def)
next
  fix s assume s: "s  S" "s  Prob0 (svalid F1) (svalid F2)  svalid F2"
  then show "𝒫(ω in T s. pvalid (U F1 F2) (s ## ω)) - 0 =
    (tS. τ s t * 𝒫(ω in T t. pvalid (U F1 F2) (t ## ω)))"
    unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S]
    by (subst prob_sum) (auto simp add: suntil_Stream)
next
  fix s assume "s  Prob0 (svalid F1) (svalid F2)  svalid F2"
  then show "l s = 𝒫(ω in T s. pvalid (U F1 F2) (s ## ω))"
  proof
    assume P0: "s  Prob0 (svalid F1) (svalid F2)"
    then have "s  S" "AE ω in T s. ¬ (HLD (svalid F1) suntil HLD (svalid F2)) (s ## ω)"
      unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S] by auto
    then have "𝒫(ω in T s. pvalid (U F1 F2) (s ## ω)) = 0"
      by (intro T.prob_eq_0_AE) simp
    moreover have "l s = 0"
      using s  S P0 sol[THEN bspec, of s] Prob0_subset_S
        Prob0_imp_not_Psi[OF svalid_subset_S svalid_subset_S P0]
      by (auto simp: LES_def single_l split: if_split_asm)
    ultimately show "l s = 𝒫(ω in T s. pvalid (U F1 F2) (s ## ω))" by simp
  next
    assume s: "s  svalid F2"
    moreover with svalid_subset_S have "s  S" by auto
    moreover note Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S s]
    ultimately have "l s = 1"
      using sol[THEN bspec, of s]
      by (auto simp: LES_def single_l dest: Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S])
    then show "l s = 𝒫(ω in T s. pvalid (U F1 F2) (s ## ω))"
      using s by (simp add: suntil_Stream)
  qed
qed

lemma infinite_reward:
  fixes s F
  defines "N  Prob0 S (svalid F)" (is "_  Prob0 S ?F")
  defines "Y  Prob1 N S (svalid F)"
  assumes s: "s  S" "s  Y"
  shows "(+ω. reward (Future F) (s ## ω) T s) = "
proof -
  { assume "(AE ω in T s. ev (HLD ?F) ω)"
    with AE_T_enabled have "(AE ω in T s. (HLD S suntil HLD ?F) ω)"
    proof eventually_elim
      fix ω assume "ev (HLD ?F) ω" "enabled s ω"
      from this s  S show "(HLD S suntil HLD ?F) ω"
      proof (induction arbitrary: s)
        case (step ω) show ?case
          using E_closed step.IH[of "shd ω"] step.prems
          by (auto simp: subset_eq enabled.simps[of s] suntil.simps[of _ _ ω] HLD_iff)
       qed (auto intro: suntil.intros)
    qed }
  moreover have "¬ (AE ω in T s. (HLD S suntil HLD ?F) (s ## ω))"
    using s svalid_subset_S unfolding N_def Y_def by (simp add: Prob1_iff)
  ultimately have *: "¬ (AE ω in T s. ev (HLD ?F) (s ## ω))"
    using s  S by (cases "s  ?F") (auto simp add: suntil_Stream ev_Stream)

  show ?thesis
  proof (rule ccontr)
    assume "¬ ?thesis"
    from nn_integral_PInf_AE[OF _ this] sS
    have "AE ω in T s. ev (HLD ?F) (s ## ω)"
      by (simp split: if_split_asm)
    with * show False ..
  qed
qed

subsubsection ‹The expected reward implies a unique LES›

lemma existence_of_ExpFuture:
  fixes s F
  assumes N_def: "N  Prob0 S (svalid F)" (is "_  Prob0 S ?F")
  assumes Y_def: "Y  Prob1 N S (svalid F)"
  assumes s: "s  S" "s  S - (Y - ?F)"
  shows "enn2real (+ω. reward (Future F) (s ## ω) T s) - (ρ s + (s'S. τ s s' * ι s s')) =
    (s'S. τ s s' * enn2real (+ω. reward (Future F) (s' ## ω) T s'))"
proof -
  let ?R = "reward (Future F)"

  from s have "s  Prob1 (Prob0 S ?F) S ?F"
    unfolding Y_def N_def by auto
  then have AE_until: "AE ω in T s. (HLD S suntil HLD (svalid F)) (s ## ω)"
    using Prob1_iff[of S ?F] svalid_subset_S by auto

  from s have "s  ?F" by auto

  let ?E = "λs'. + ω. reward (Future F) (s' ## ω) T s'"
  have *: "(s'S. τ s s' * ?E s') = (s'S. ennreal (τ s s' * enn2real (?E s')))"
  proof (rule sum.cong)
    fix s' assume "s'  S"
    show s s' * ?E s' = ennreal (τ s s' * enn2real (?E s'))"
    proof cases
      assume s s'  0"
      with s  S s'  S have "s'  E s" by (simp add: set_pmf_iff)
      from s  ?F AE_until have "AE ω in T s. (HLD S suntil HLD ?F) (s ## ω)"
        using svalid_subset_S s  S by simp
      with nn_integral_reward_finite[OF s'  S, of F] s  S s'  E s s  ?F
      have "?E s'  "
        by (simp add: AE_T_iff[of _ s] AE_measure_pmf_iff suntil_Stream
                 del: reward.simps)
      then show ?thesis by (cases "?E s'") (auto simp: ennreal_mult)
    qed simp
  qed simp

  have "AE ω in T s. ?R (s ## ω) = ρ s + ι s (shd ω) + ?R ω"
    using s  svalid F by (auto simp: ev_Stream )
  then have "(+ω. ?R (s ## ω) T s) = (+ω. (ρ s + ι s (shd ω)) + ?R ω T s)"
    by (rule nn_integral_cong_AE)
  also have " = (+ω. ρ s + ι s (shd ω) T s) +
    (+ω. ?R ω T s)"
    using s  S
    by (subst nn_integral_add)
       (auto simp add: space_PiM PiE_iff simp del: reward.simps)
  also have " = ennreal (ρ s + (s'S. τ s s' * ι s s')) + (+ω. ?R ω T s)"
    using s  S
    by (subst nn_integral_eq_sum)
       (auto simp: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric] sum_nonneg)
  finally show ?thesis
    apply (simp del: reward.simps)
    apply (subst nn_integral_eq_sum[OF s  S reward_measurable])
    apply (simp del: reward.simps ennreal_plus add: * ennreal_plus[symmetric] sum_nonneg)
    done
qed

lemma uniqueness_of_ExpFuture:
  fixes F
  assumes N_def: "N  Prob0 S (svalid F)" (is "_  Prob0 S ?F")
  assumes Y_def: "Y  Prob1 N S (svalid F)"
  assumes const_def: "const  λs. if s  Y  s  svalid F then - ρ s - (s'S. τ s s' * ι s s') else 0"
  assumes sol: "s. sS  (s'S. LES (S - Y  ?F) s s' * l s') = const s"
  shows "sS. l s = enn2real (+ω. reward (Future F) (s ## ω) T s)"
    (is "sS. l s = enn2real (+ω. ?R (s ## ω) T s)")
proof (rule unique)
  show "S  S" "?F  S" using svalid_subset_S by auto
  show "S - (Y - ?F)  S" "Prob0 S ?F  S - (Y - ?F)" "?F  S - (Y - ?F)"
    using svalid_subset_S
    by (auto simp add: Y_def N_def Prob1_iff)
       (auto simp add: Prob0_iff dest!: T.AE_contr)
next
  fix s assume "s  S" "s  S - (Y - ?F)"
  then show "enn2real (+ω. ?R (s ## ω) T s) - (ρ s + (s'S. τ s s' * ι s s')) =
    (s'S. τ s s' * enn2real (+ω. ?R (s' ## ω) T s'))"
    by (rule existence_of_ExpFuture[OF N_def Y_def])
next
  fix s assume "s  S" "s  S - (Y - ?F)"
  then have "s  Y" "s  ?F" by auto
  have "(s'S. (if s' = s then τ s s' - 1 else τ s s') * l s') =
    (s'S. τ s s' * l s' - (if s' = s then 1 else 0) * l s')"
    by (auto intro!: sum.cong simp: field_simps)
  also have " = (s'S. τ s s' * l s') - l s"
    using s  S by (simp add: sum_subtractf single_l)
  finally have "l s = (s'S. τ s s' * l s') - (s'S. (if s' = s then τ s s' - 1 else τ s s') * l s')"
    by (simp add: field_simps)
  then show "l s - (ρ s + (s'S. τ s s' * ι s s')) = (s'S. τ s s' * l s')"
    using sol[OF s  S] s  Y s  ?F by (simp add: const_def LES_def)
next
  fix s assume s: "s  S - (Y - ?F)"
  with sol[of s] have "l s = 0"
    by (cases "s  ?F") (simp_all add: const_def LES_def single_l)
  also have "0 = enn2real (+ω. reward (Future F) (s ## ω) T s)"
  proof cases
    assume "s  ?F" then show ?thesis
      by (simp add: HLD_iff ev_Stream)
  next
    assume "s  ?F"
    with s have "s  S - Y" by auto
    with infinite_reward[of s F] show ?thesis
      by (simp add: Y_def N_def del: reward.simps)
  qed
  finally show "l s = enn2real (+ω. ?R (s ## ω) T s)" .
qed

subsection ‹Soundness of @{const Sat}

theorem Sat_sound:
  "Sat F  None  Sat F = Some (svalid F)"
proof (induct F rule: Sat.induct)
  case (5 rel r F)
  { fix q assume "q  S"
    with svalid_subset_S have "sum (τ q) (svalid F) = 𝒫(ω in T q. HLD (svalid F) ω)"
      by (subst prob_sum[OF qS]) (auto intro!: sum.mono_neutral_cong_left) }
  with 5 show ?case
    by (auto split: bind_split_asm)

next
  case (6 rel r k F1 F2)
  then show ?case
    by (simp add: ProbU cong: conj_cong split: bind_split_asm)

next
  case (7 rel r F1 F2)
  moreover
  define constants :: "'s  real" where "constants = (λs. if s  (svalid F2) then 1 else 0)"
  moreover define distr where "distr = LES (Prob0 (svalid F1) (svalid F2)  svalid F2)"
  ultimately obtain l where eq: "Sat F1 = Some (svalid F1)" "Sat F2 = Some (svalid F2)"
    and l: "gauss_jordan' distr constants = Some l"
    by atomize_elim (simp add: ProbUinfty_def split: bind_split_asm)

  from l have P: "ProbUinfty (svalid F1) (svalid F2) = Some l"
    unfolding ProbUinfty_def constants_def distr_def by simp

  have "sS. l s = 𝒫(ω in T s. pvalid (U F1 F2) (s ## ω))"
  proof (rule uniqueness_of_ProbU)
    show "sS. (s'S. LES (Prob0 (svalid F1) (svalid F2)  svalid F2) s s' * l s') =
                   (if s  svalid F2 then 1 else 0)"
      using gauss_jordan'_correct[OF l]
      unfolding distr_def constants_def by simp
  qed
  then show ?case
    by (auto simp add: eq P)
next
  case (8 rel r k)
  { fix s assume "s  S"
    then have "ExpCumm s k = (+ x. ennreal (i<k. ρ ((s ## x) !! i) + ι ((s ## x) !! i) (x !! i)) T s)"
    proof (induct k arbitrary: s)
      case 0 then show ?case by simp
    next
      case (Suc k)
      have "(+ω. ennreal (i<Suc k. ρ ((s ## ω) !! i) + ι ((s ## ω) !! i) (ω !! i)) T s)
        = (+ω. ennreal (ρ s + ι s (ω !! 0)) + ennreal (i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) T s)"
        by (auto intro!: nn_integral_cong
                 simp del: ennreal_plus
                 simp: ennreal_plus[symmetric] sum_nonneg sum.reindex lessThan_Suc_eq_insert_0 zero_notin_Suc_image)
      also have " = (+ω. ρ s + ι s (ω !! 0) T s) +
          (+ω. (i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) T s)"
        using s  S
        by (intro nn_integral_add AE_I2) (auto simp: sum_nonneg)
      also have " = (s'S. τ s s' * (ρ s + ι s s')) +
        (+ω. (i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) T s)"
        using s  S by (subst nn_integral_eq_sum)
          (auto simp del: ennreal_plus simp: ennreal_plus[symmetric] ennreal_mult[symmetric] sum_nonneg)
      also have " = (s'S. τ s s' * (ρ s + ι s s')) +
        (s'S. τ s s' * ExpCumm s' k)"
        using s  S by (subst nn_integral_eq_sum) (auto simp: Suc)
      also have " = ExpCumm s (Suc k)"
        using s  S
        by (simp add: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric]
            ennreal_plus[symmetric] sum_nonneg del: ennreal_plus)
      finally show ?case by simp
    qed }
  then show ?case by auto

next
  case (9 rel r k)
  { fix s assume "s  S"
    then have "ExpState s k = (+ x. ennreal (ρ ((s ## x) !! k)) T s)"
    proof (induct k arbitrary: s)
      case (Suc k) then show ?case by (simp add: nn_integral_eq_sum[of s])
    qed simp }
  then show ?case by auto

next
  case (10 rel r F)
  moreover
  let ?F = "svalid F"
  define N where "N  Prob0 S ?F"
  moreover define Y where "Y  Prob1 N S ?F"
  moreover define const where "const  (λs. if s  Y  s  ?F then - ρ s - (s'S. τ s s' * ι s s') else 0)"
  ultimately obtain l
    where l: "gauss_jordan' (LES (S - Y  ?F)) const = Some l"
    and F: "Sat F = Some ?F"
    by (auto simp: ExpFuture_def Let_def split: bind_split_asm)

  from l have EF: "ExpFuture ?F =
    Some (λs. if s  Y then ennreal (l s) else )"
    unfolding ExpFuture_def N_def Y_def const_def by auto

  let ?R = "reward (Future F)"
  have l_eq: "sS. l s = enn2real (+ω. ?R (s ## ω) T s)"
  proof (rule uniqueness_of_ExpFuture[OF N_def Y_def const_def])
    fix s assume "s  S"
    show "s. sS  (s'S. LES (S - Y  ?F) s s' * l s') = const s"
      using gauss_jordan'_correct[OF l] by auto
  qed
  { fix s assume [simp]: "s  S" "s  Y"
    then have "s  Prob1 (Prob0 S ?F) S ?F"
      unfolding Y_def N_def by auto
    then have "AE ω in T s. (HLD S suntil HLD ?F) (s ## ω)"
      using svalid_subset_S by (auto simp add: Prob1_iff)
    from nn_integral_reward_finite[OF s  S] this
    have "(+ω. reward (Future F) (s ## ω) T s)  "
      by (simp add: )
    with l_eq s  S have "(+ω. reward (Future F) (s ## ω) T s) = ennreal (l s)"
      by (auto simp: less_top) }
  moreover
  { fix s assume "s  S" "s  Y"
    with infinite_reward[of s F]
    have "(+ω. reward (Future F) (s ## ω) T s) = "
      by (simp add: Y_def N_def) }
  ultimately show ?case
    apply (auto simp add: EF F simp del: reward.simps)
    apply (case_tac "x  Y")
    apply auto
    done
qed (auto split: bind_split_asm)

subsection ‹Completeness of @{const Sat}

theorem Sat_complete:
  "Sat F  None"
proof (induct F rule: Sat.induct)
  case (7 r rel Φ Ψ)
  then have F: "Sat Φ = Some (svalid Φ)" "Sat Ψ = Some (svalid Ψ)"
    by (auto intro!: Sat_sound)

  define constants :: "'s  real" where "constants = (λs. if s  svalid Ψ then 1 else 0)"
  define distr where "distr = LES (Prob0 (svalid Φ) (svalid Ψ)  svalid Ψ)"
  have "l. gauss_jordan' distr constants = Some l"
  proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ProbU])
    show "sS. (s'S. distr s s' * 𝒫(ω in T s'. pvalid (U Φ Ψ) (s' ## ω))) = constants s"
      apply (simp add: distr_def constants_def LES_def del: pvalid.simps space_T)
    proof safe
      fix s assume "s  svalid Ψ" "s  S"
      then show "(s'S. (if s' = s then 1 else 0) * 𝒫(ω in T s'. pvalid (U Φ Ψ) (s' ## ω))) = 1"
        by (simp add: single_l suntil_Stream)
    next
      fix s assume s: "s  svalid Ψ" "s  S"
      let ?x = "λs'. 𝒫(ω in T s'. pvalid (U Φ Ψ) (s' ## ω))"
      show "(s'S. (if s  Prob0 (svalid Φ) (svalid Ψ) then if s' = s then 1 else 0 else if s' = s then τ s s' - 1 else τ s s') * ?x s') = 0"
      proof cases
        assume "s  Prob0 (svalid Φ) (svalid Ψ)"
        with s show ?thesis
          by (simp add: single_l Prob0_iff svalid_subset_S T.prob_eq_0_AE del: space_T)
      next
        assume s_not_0: "s  Prob0 (svalid Φ) (svalid Ψ)"
        with s have *:"s' ω. s'  S  pvalid (U Φ Ψ) (s ## s' ## ω) = pvalid (U Φ Ψ) (s' ## ω)"
          by (auto simp: suntil_Stream Prob0_iff svalid_subset_S)

        have "(s'S. (if s' = s then τ s s' - 1 else τ s s') * ?x s') =
          (s'S. τ s s' * ?x s' - (if s' = s then 1 else 0) * ?x s')"
          by (auto intro!: sum.cong simp: field_simps)
        also have " = (s'S. τ s s' * ?x s') - ?x s"
          using s by (simp add: single_l sum_subtractf)
        finally show ?thesis
          using * prob_sum[OF s  S] s_not_0 by (simp del: pvalid.simps)
      qed
    qed
  qed (simp add: distr_def constants_def)
  then have P: "l. ProbUinfty (svalid Φ) (svalid Ψ) = Some l"
    unfolding ProbUinfty_def constants_def distr_def by simp
  with F show ?case
    by auto
next
  case (10 rel r Φ)
  then have F: "Sat Φ = Some (svalid Φ)"
    by (auto intro!: Sat_sound)

  let ?F = "svalid Φ"
  define N where "N  Prob0 S ?F"
  define Y where "Y  Prob1 N S ?F"
  define const where "const  (λs. if s  Y  s  ?F then - ρ s - (s'S. τ s s' * ι s s') else 0)"
  let ?E = "λs'. + ω. reward (Future Φ) (s' ## ω) T s'"
  have "l. gauss_jordan' (LES (S - Y  ?F)) const = Some l"
  proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ExpFuture[OF N_def Y_def const_def]])
    show "sS. (s'S. LES (S - Y  svalid Φ) s s' * enn2real (?E s')) = const s"
    proof
      fix s assume "s  S"
      show "(s'S. LES (S - Y  svalid Φ) s s' * enn2real (?E s')) = const s"
      proof cases
        assume s: "s  S - (Y - svalid Φ)"
        show ?thesis
        proof cases
          assume "s  Y"
          with s  S s s  Y show ?thesis
            by (simp add: LES_def const_def single_l ev_Stream)
        next
          assume "s  Y"
          with infinite_reward[of s Φ] Y_def N_def s s  S
          show ?thesis by (simp add: const_def LES_def single_l del: reward.simps)
        qed
      next
        assume s: "s  S - (Y - svalid Φ)"

        have "(s'S. (if s' = s then τ s s' - 1 else τ s s') * enn2real (?E s')) =
          (s'S. τ s s' * enn2real (?E s') - (if s' = s then 1 else 0) * enn2real (?E s'))"
          by (auto intro!: sum.cong simp: field_simps)
        also have " = (s'S. τ s s' * enn2real (?E s')) - enn2real (?E s)"
          using s  S by (simp add: sum_subtractf single_l)
        finally show ?thesis
          using s s  S existence_of_ExpFuture[OF N_def Y_def s  S s]
          by (simp add: LES_def const_def del: reward.simps)
      qed
    qed
  qed simp
  then have P: "l. ExpFuture (svalid Φ) = Some l"
    unfolding ExpFuture_def const_def N_def Y_def by auto
  with F show ?case
    by auto
qed (force split: bind_split)+

subsection ‹Completeness and Soundness @{const Sat}

corollary Sat: "Sat Φ = Some (svalid Φ)"
  using Sat_sound Sat_complete by auto

end

end

Theory PGCL

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Probabilistic Guarded Command Language (pGCL)›

theory PGCL
  imports "../Markov_Decision_Process"
begin

subsection ‹Syntax›

datatype 's pgcl =
    Skip
  | Abort
  | Assign "'s  's"
  | Seq "'s pgcl" "'s pgcl"
  | Par "'s pgcl" "'s pgcl"
  | If "'s  bool" "'s pgcl" "'s pgcl"
  | Prob "bool pmf" "'s pgcl" "'s pgcl"
  | While "'s  bool" "'s pgcl"

subsection ‹Denotational Semantics›

primrec wp :: "'s pgcl  ('s  ennreal)  ('s  ennreal)" where
  "wp Skip f          = f"
| "wp Abort f         = (λ_. 0)"
| "wp (Assign u) f    = f  u"
| "wp (Seq c1 c2) f    = wp c1 (wp c2 f)"
| "wp (If b c1 c2) f   = (λs. if b s then wp c1 f s else wp c2 f s)"
| "wp (Par c1 c2) f    = wp c1 f  wp c2 f"
| "wp (Prob p c1 c2) f = (λs. pmf p True * wp c1 f s + pmf p False * wp c2 f s)"
| "wp (While b c) f   = lfp (λX s. if b s then wp c X s else f s)"

lemma wp_mono: "mono (wp c)"
  by (induction c)
     (auto simp: mono_def le_fun_def intro: order_trans le_infI1 le_infI2
           intro!: add_mono mult_left_mono lfp_mono[THEN le_funD])

abbreviation det :: "'s pgcl  's  ('s pgcl × 's) pmf set" (" _, _ ") where
  "det c s  {return_pmf (c, s)}"

subsection ‹Operational Semantics›

fun step :: "('s pgcl × 's)  ('s pgcl × 's) pmf set" where
  "step (Skip, s)        = Skip, s"
| "step (Abort, s)       = Abort, s"
| "step (Assign u, s)    = Skip, u s"
| "step (Seq c1 c2, s)    = (map_pmf (λ(p1', s'). (if p1' = Skip then c2 else Seq p1' c2, s'))) ` step (c1, s)"
| "step (If b c1 c2, s)   = (if b s then c1, s else c2, s)"
| "step (Par c1 c2, s)    = c1, s  c2, s"
| "step (Prob p c1 c2, s) = {map_pmf (λb. if b then (c1, s) else (c2, s)) p}"
| "step (While b c, s)   = (if b s then Seq c (While b c), s else Skip, s)"

lemma step_finite: "finite (step x)"
  by (induction x rule: step.induct) simp_all

lemma step_non_empty: "step x  {}"
  by (induction x rule: step.induct) simp_all

interpretation step: Markov_Decision_Process step
  proof qed (rule step_non_empty)

definition rF :: "('s  ennreal)  (('s pgcl × 's) stream  ennreal)  ('s pgcl × 's) stream  ennreal" where
  "rF f F ω = (if fst (shd ω) = Skip then f (snd (shd ω)) else F (stl ω))"

abbreviation r :: "('s  ennreal)  ('s pgcl × 's) stream  ennreal" where
  "r f  lfp (rF f)"

lemma continuous_rF: "sup_continuous (rF f)"
  unfolding rF_def[abs_def]
  by (auto simp: sup_continuous_def fun_eq_iff SUP_sup_distrib [symmetric] image_comp
           split: prod.splits pgcl.splits)

lemma mono_rF: "mono (rF f)"
  using continuous_rF by (rule sup_continuous_mono)

lemma r_unfold: "r f ω = (if fst (shd ω) = Skip then f (snd (shd ω)) else r f (stl ω))"
  by (subst lfp_unfold[OF mono_rF]) (simp add: rF_def)

lemma mono_r: "F  G  r F ω  r G ω"
  by (rule le_funD[of _ _ ω], rule lfp_mono)
     (auto intro!: lfp_mono simp: rF_def le_fun_def max.coboundedI2)

lemma measurable_rF:
  assumes F[measurable]: "F  borel_measurable step.St"
  shows "rF f F  borel_measurable step.St"
  unfolding rF_def[abs_def]
  apply measurable
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable []
  apply (rule measurable_compose[OF measurable_stl])
  apply measurable []
  apply (rule predE)
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable
  done

lemma measurable_r[measurable]: "r f  borel_measurable step.St"
  using continuous_rF measurable_rF by (rule borel_measurable_lfp)

lemma mono_r': "mono (λF s. Dstep s. + t. (if fst t = Skip then f (snd t) else F t) measure_pmf D)"
  by (auto intro!: monoI le_funI INF_mono[OF bexI] nn_integral_mono simp: le_fun_def)

lemma E_inf_r:
  "step.E_inf s (r f) =
    lfp (λF s. Dstep s. + t. (if fst t = Skip then f (snd t) else F t) measure_pmf D) s"
proof -
  have "step.E_inf s (r f) =
    lfp (λF s. Dstep s. + t. (if fst t = Skip then f (snd t) else F t) measure_pmf D) s"
    unfolding rF_def[abs_def]
  proof (rule step.E_inf_lfp[THEN fun_cong])
    let ?F = "λt x. (if fst t = Skip then f (snd t) else x)"
    show "(λ(s, x). ?F s x)  borel_measurable (count_space UNIV M borel)"
      apply (simp add: measurable_split_conv split_beta')
      apply (intro borel_measurable_max borel_measurable_const measurable_If predE
         measurable_compose[OF measurable_snd] measurable_compose[OF measurable_fst])
      apply measurable
      done
    show "s. sup_continuous (?F s)"
      by (auto simp: sup_continuous_def SUP_sup_distrib[symmetric] split: prod.split pgcl.split)
    show "F cfg. (+ω. ?F (state cfg) (F ω) step.T cfg) =
      ?F (state cfg) (nn_integral (step.T cfg) F)"
      by (auto simp: split: pgcl.split prod.split)
  qed (rule step_finite)
  then show ?thesis
    by simp
qed

lemma E_inf_r_unfold:
  "step.E_inf s (r f) = (Dstep s. + t. (if fst t = Skip then f (snd t) else step.E_inf t (r f)) measure_pmf D)"
  unfolding E_inf_r by (simp add: lfp_unfold[OF mono_r'])

lemma E_inf_r_induct[consumes 1, case_names step]:
  assumes "P s y"
  assumes *: "F s y. P s y 
    (s y. P s y  F s  y)  (s. F s  step.E_inf s (r f)) 
    (Dstep s. + t. (if fst t = Skip then f (snd t) else F t) measure_pmf D)  y"
  shows "step.E_inf s (r f)  y"
  using P s y
  unfolding E_inf_r
proof (induction arbitrary: s y rule: lfp_ordinal_induct[OF mono_r'[where f=f]])
  case (1 F) with *[of s y F] show ?case
    unfolding le_fun_def E_inf_r[where f=f, symmetric] by simp
qed (auto intro: SUP_least)

lemma E_inf_Skip: "step.E_inf (Skip, s) (r f) = f s"
  by (subst E_inf_r_unfold) simp

lemma E_inf_Seq:
  assumes [simp]: "x. 0  f x"
  shows "step.E_inf (Seq a b, s) (r f) = step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f)))"
proof (rule antisym)
  show "step.E_inf (Seq a b, s) (r f)  step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f)))"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_  " E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
  qed
  show "step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f)))  step.E_inf (Seq a b, s) (r f)"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_  " E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
   qed
qed

lemma E_inf_While:
  "step.E_inf (While g c, s) (r f) =
    lfp (λF s. if g s then step.E_inf (c, s) (r F) else f s) s"
proof (rule antisym)
  have E_inf_While_step: "step.E_inf (While g c, s) (r f) =
    (if g s then step.E_inf (c, s) (r (λs. step.E_inf (While g c, s) (r f))) else f s)" for f s
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1 E_inf_Seq)

  have "mono (λF s. if g s then step.E_inf (c, s) (r F) else f s)" (is "mono ?F")
    by (auto intro!: mono_r step.E_inf_mono simp: mono_def le_fun_def max.coboundedI2)
  then show "lfp ?F s  step.E_inf (While g c, s) (r f)"
  proof (induction arbitrary: s rule: lfp_ordinal_induct[consumes 1])
    case mono then show ?case
      by (rewrite E_inf_While_step) (auto intro!: step.E_inf_mono mono_r le_funI)
  qed (auto intro: SUP_least)

  define w where "w F s = (Dstep s. + t. (if fst t = Skip then if g (snd t) then F (c, snd t) else f (snd t) else F t) measure_pmf D)"
    for F s
  have "mono w"
    by (auto simp: w_def mono_def le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono) []

  define d where "d = c"
  define t where "t = Seq d (While g c)"
  then have "(t = While g c  d = c  g s)  t = Seq d (While g c)"
    by auto
  then have "step.E_inf (t, s) (r f)  lfp w (d, s)"
  proof (coinduction arbitrary: t d s rule: E_inf_r_induct)
    case (step F t d s)
    from step(1)
    show ?case
    proof (elim conjE disjE)
      { fix s have "¬ g s  F (While g c, s)  f s"
          using step(3)[of "(While g c, s)"] by (simp add: E_inf_While_step) }
      note [simp] = this
      assume "t = Seq d (While g c)" then show ?thesis
        by (rewrite lfp_unfold[OF ‹mono w])
           (auto simp: max.absorb2 w_def intro!: INF_mono[OF bexI] nn_integral_mono step)
    qed (auto intro!: step)
  qed
  also have "lfp w = lfp (λF s. step.E_inf s (r (λs. if g s then F (c, s) else f s)))"
    unfolding E_inf_r w_def
    by (rule lfp_lfp[symmetric]) (auto simp: le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono)
  finally have "step.E_inf (While g c, s) (r f)  (if g s then  (c, s) else f s)"
    unfolding t_def d_def by (rewrite E_inf_r_unfold) simp
  also have " = lfp ?F s"
    by (rewrite lfp_rolling[symmetric, of "λF s. if g s then F (c, s) else f s"  "λF s. step.E_inf s (r F)"])
       (auto simp: mono_def le_fun_def sup_apply[abs_def] if_distrib[of "max 0"] max.coboundedI2 max.absorb2
                intro!: step.E_inf_mono mono_r cong del: if_weak_cong)
  finally show "step.E_inf (While g c, s) (r f)  "
    .
qed

subsection ‹Equate Both Semantics›

lemma E_inf_r_eq_wp: "step.E_inf (c, s) (r f) = wp c f s"
proof (induction c arbitrary: f s)
  case Skip then show ?case
    by (simp add: E_inf_Skip)
next
  case Abort then show ?case
  proof (intro antisym)
    have "lfp (λF s. Dstep s. + t. (if fst t = Skip then f (snd t) else F t) measure_pmf D) 
      (λs. if t. s = (Abort, t) then 0 else )"
      by (intro lfp_lowerbound) (auto simp: le_fun_def)
    then show "step.E_inf (Abort, s) (r f)  wp Abort f s"
      by (auto simp: E_inf_r le_fun_def split: if_split_asm)
  qed simp
next
  case Assign then show ?case
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1)
next
  case (If b c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) auto
next
  case (Prob p c1 c2) then show ?case
    apply (rewrite E_inf_r_unfold)
    apply auto
    apply (rewrite nn_integral_measure_pmf_support[of "UNIV::bool set"])
    apply (auto simp: UNIV_bool ac_simps)
    done
next
  case (Par c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) (auto intro: inf.commute)
next
  case (Seq c1 c2) then show ?case
    by (simp add: E_inf_Seq)
next
  case (While g c) then show ?case
    apply (simp add: E_inf_While)
    apply (rewrite While)
    apply auto
    done
qed

end

Theory Crowds_Protocol

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Formalization of the Crowds-Protocol›

theory Crowds_Protocol
  imports "../Discrete_Time_Markov_Chain"
begin

lemma cond_prob_nonneg[simp]: "0  cond_prob M A B"
  by (auto simp: cond_prob_def)

lemma (in MC_syntax) emeasure_suntil_geometric:
  assumes [measurable]: "Measurable.pred S P"
  assumes "s  X" and *[simp]: "0  p" "0  r"
  assumes r: "s. s  X  emeasure (T s) {ωspace (T s). P ω} = ennreal r"
  assumes p: "s. s  X  emeasure (K s) X = ennreal p" "p < 1"
  assumes "t. AE ω in T t. ¬ (P  (HLD X  nxt (HLD X suntil P))) ω"
  shows "emeasure (T s) {ωspace (T s). (HLD X suntil P) ω} = r / (1 - p)"
proof (subst emeasure_suntil_disj)
  let ?F = "λF s. emeasure (T s) {ω  space (T s). P ω} + + t. F t * indicator X t K s"
  let ?f = "λx. ennreal r + ennreal p * x"

  have "mono ?F" "mono ?f"
    by (auto intro!: monoI max.mono add_mono nn_integral_mono mult_left_mono mult_right_mono simp: le_fun_def)

  have 1: "lfp ?f  lfp ?F s"
    using s  X
  proof (induction arbitrary: s rule: lfp_ordinal_induct[OF ‹mono ?f])
    case step: (1 x)
    then have "?f x  ?F (λ_. x) s"
      by (auto simp: p r[simplified] nn_integral_cmult mult.commute[of _ x]
               intro!: add_mono mult_right_mono)
    also have "?F (λ_. x)  ?F (lfp ?F)"
      using step
      by (intro le_funI add_mono order_refl nn_integral_mono) (auto simp: split: split_indicator)
    finally show ?case
      by (subst lfp_unfold[OF ‹mono ?F]) (auto simp: le_fun_def)
  qed (auto intro!: Sup_least)
  also have 2: "lfp ?F s  r / (1 - p)"
    using s  X
  proof (induction arbitrary: s rule: lfp_ordinal_induct[OF ‹mono ?F])
    case (1 S)
    with r have "?F S s  ennreal r + (+x. ennreal (r / (1 - p)) * indicator X x K s)"
      by (intro add_mono nn_integral_mono) (auto split: split_indicator)
    also have "  ennreal r + ennreal (r * p / (1 - p))"
      using s  X by (simp add: nn_integral_cmult_indicator p ennreal_mult''[symmetric])
    also have " = ennreal (r / (1 - p))"
      using p < 1 by (simp add: field_simps ennreal_plus[symmetric] del: ennreal_plus)
    finally show ?case .
  qed (auto intro!: SUP_least)
  finally obtain x where x: "lfp ?f = ennreal x" and [simp]: "0  x"
    by (cases "lfp ?f") (auto simp: top_unique)
  from p < 1 have "x. x = r + p * x  x = r / (1 - p)"
    by (auto simp: field_simps)
  with lfp_unfold[OF ‹mono ?f] p < 1 have "lfp ?f = r / (1 - p)"
    unfolding x by (auto simp add: ennreal_plus[symmetric] ennreal_mult[symmetric] simp del: ennreal_plus)
  with 1 2 show "lfp ?F s = ennreal (r / (1 - p))"
    by auto
qed fact+

subsection ‹Definition of the Crowds-Protocol›

datatype 'a state = Start | Init 'a | Mix 'a | End

lemma inj_Mix[simp]: "inj_on Mix A"
  by (auto intro: inj_onI)

lemma inj_Init[simp]: "inj_on Init A"
  by (auto intro: inj_onI)

lemma distinct_state_image[simp]:
  "Start  Mix ` A" "Init j  Mix ` A" "End  Mix ` A" "Mix j  Mix ` A  j  A"
  "Start  Init ` A" "Mix j  Init ` A" "End  Init ` A" "Init j  Init ` A  j  A"
  by auto

lemma Init_cut_Mix[simp]:
  "Init ` H  Mix ` J = {}"
  by auto

abbreviation "Jondo B  Init`B  Mix`B"

locale Crowds_Protocol =
  fixes J :: "'a set" and C :: "'a set" and p_f :: real and p_i :: "'a  real"
  assumes J_not_empty: "J  {}" and finite_J[simp]: "finite J"
  assumes C_smaller: "C  J" and C_non_empty: "C  {}"
  assumes p_f: "0 < p_f" "p_f < 1"
  assumes p_i_nonneg[simp]: "j. j  J  0  p_i j"
  assumes p_i_distr: "(jJ. p_i j) = 1"
  assumes p_i_C: "j. j  C  p_i j = 0"
begin

abbreviation H :: "'a set" where
  "H  J - C"

definition "p_j = 1 / card J"

lemma p_f_nonneg[simp]: "0  p_f" "p_f  1"
  using p_f by simp_all

lemma p_j_nonneg[simp]: "0  p_j"
  by (simp add: p_j_def)

definition "p_H = card H / card J"

lemma p_H_nonneg[simp]: "0  p_H" "p_H  1"
  by (auto simp: p_H_def divide_le_eq_1 card_gt_0_iff intro!: card_mono )

definition next_prob :: "'a state  'a state  real" where
  "next_prob s t = (case (s, t) of (Start, Init j)  if j  H then p_i j else 0
                                 | (Init j, Mix j')  if j'  J then p_j else 0
                                 | (Mix j, Mix j')  if j'  J then p_f * p_j else 0
                                 | (Mix j, End)  1 - p_f
                                 | (End, End)  1
                                 | _  0)"

definition "N s = embed_pmf (next_prob s)"

interpretation MC_syntax N .

abbreviation "𝔓  T Start"

abbreviation "E s  set_pmf (N s)"

lemma finite_C[simp]: "finite C"
  using C_smaller finite_J by (blast intro: finite_subset)

lemma sum_p_i_C[simp]: "sum p_i C = 0"
  by (auto intro: sum.neutral p_i_C)

lemma sum_p_i_H[simp]: "sum p_i H = 1"
  using C_smaller by (simp add: sum_diff p_i_distr)

lemma possible_jondo:
  obtains j where "j  J" "j  C" "p_i j  0"
proof (atomize_elim, rule ccontr)
  assume "¬ (j. j  J  j  C  p_i j  0)"
  with p_i_C have "jJ. p_i j = 0"
    by auto
  with p_i_distr show False
    by simp
qed

lemma C_le_J[simp]: "card C < card J"
  using C_smaller
  by (intro psubset_card_mono) auto

lemma p_H: "0 < p_H" "p_H < 1"
  using J_not_empty C_smaller C_non_empty
  by (simp_all add: p_H_def card_Diff_subset card_mono field_simps zero_less_divide_iff card_gt_0_iff)

lemma p_H_p_f_pos: "0 < p_H * p_f"
  using p_f p_H by (simp add: zero_less_mult_iff)

lemma p_H_p_f_less_1: "p_H * p_f < 1"
proof -
  have "p_H * p_f < 1 * 1"
    using p_H p_f by (intro mult_strict_mono) auto
  then show "p_H * p_f < 1" by simp
qed

lemma p_j_pos: "0 < p_j"
  unfolding p_j_def using J_not_empty by auto

lemma H_compl: "1 - p_H = real (card C) / real (card J)"
  using C_non_empty J_not_empty C_smaller
  by (simp add: p_H_def card_Diff_subset card_mono of_nat_diff divide_eq_eq field_simps)

lemma H_compl2: "1 - p_H = card C * p_j"
  unfolding H_compl p_j_def by simp

lemma H_eq2: "card H * p_j = p_H"
  unfolding p_j_def p_H_def by simp

lemma pmf_next_pmf[simp]: "pmf (N s) t = next_prob s t"
  unfolding N_def
proof (rule pmf_embed_pmf)
  show "x. 0  next_prob s x"
    using p_j_pos p_f by (auto simp: next_prob_def intro: p_i_nonneg split: state.split)
  show "(+ x. ennreal (next_prob s x) count_space UNIV) = 1"
    using p_f J_not_empty
    by (subst nn_integral_count_space'[where A="Init`H  Mix`J  {End}"])
       (auto simp: next_prob_def sum.reindex sum.union_disjoint p_i_distr p_j_def
             split: state.split)
qed

lemma next_prob_Start[simp]: "next_prob Start (Init j) = (if j  H then p_i j else 0)"
  by (auto simp: next_prob_def)

lemma next_prob_to_Init[simp]: "j  H  next_prob s (Init j) =
    (case s of Start  p_i j | _  0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_to_Mix[simp]: "j  J  next_prob s (Mix j) =
    (case s of Init j  p_j | Mix j  p_f * p_j | _  0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_to_End[simp]: "next_prob s End =
    (case s of Mix j  1 - p_f | End  1 | _  0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_from_End[simp]: "next_prob End s = 0  s  End"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_Mix_MixI: "j. s = Mix j  jJ. s' = Mix j  next_prob s s' = p_f * p_j"
  by (cases s) auto


lemma E_Start: "E Start = {Init j | j. j  H  p_i j  0 }"
  using p_i_C by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_Init: "E (Init j) = {Mix j | j. j  J }"
  using p_j_pos C_smaller by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_Mix: "E (Mix j) = {Mix j | j. j  J }  {End}"
  using p_j_pos p_f by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_End: "E End = {End}"
  by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma enabled_End:
  "enabled End ω  ω = sconst End"
proof safe
  assume "enabled End ω" then show "ω = sconst End"
  proof (coinduction arbitrary: ω)
    case Eq_stream then show ?case
      by (auto simp: enabled.simps[of _ ω] E_End)
  qed
next
  show "enabled End (sconst End)"
    by coinduction (simp add: E_End)
qed

lemma AE_End: "(AE ω in T End. P ω)  P (sconst End)"
proof -
  have "(AE ω in T End. P ω)  (AE ω in T End. P ω  ω = sconst End)"
    using AE_T_enabled[of End] by (simp add: enabled_End)
  also have " = (AE ω in T End. P (sconst End)  ω = sconst End)"
    by (simp add: enabled_End del: AE_conj_iff cong: rev_conj_cong)
  also have " = (AE ω in T End. P (sconst End))"
    using AE_T_enabled[of End] by (simp add: enabled_End)
  finally show ?thesis
    by simp
qed

lemma emeasure_Init_eq_Mix:
  assumes [measurable]: "Measurable.pred S P"
  assumes AE_End: "AE x in T End. ¬ P (End ## x)"
  shows "emeasure (T (Init j)) {xspace (T (Init j)). P x} =
    emeasure (T (Mix j)) {xspace (T (Mix j)). P x} / p_f"
proof -
  have *: "{Mix j | j. j  J } = Mix ` J"
    by auto
  show ?thesis
    using emeasure_eq_0_AE[OF AE_End] p_f
    apply (subst (1 2) emeasure_Collect_T)
    apply simp
    apply (subst (1 2) nn_integral_measure_pmf_finite)
    apply (auto simp: E_Mix E_Init * sum.reindex sum_distrib_right[symmetric] divide_ennreal
      ennreal_times_divide[symmetric])
    done
qed

text ‹

What is the probability that the server sees a specific jondo (including the initiator) as sender.

›

definition visit :: "'a set  'a set  'a state stream  bool" where
  "visit I L = Init`(I  H)  (HLD (Mix`J) suntil (Mix`(L  J)  HLD {End}))"

lemma visit_unique1:
  "visit I1 L1 ω  visit I2 L2 ω  I1  I2  {}"
  by (auto simp: visit_def HLD_iff)

lemma visit_unique2:
  assumes "visit I1 L1 ω" "visit I2 L2 ω"
  shows "L1  L2  {}"
proof -
  let ?U = "λL ω. (HLD (Mix`J) suntil ((Mix`(LJ))  HLD {End})) ω"
  have "?U L1 (stl ω)" "?U L2 (stl ω)"
    using assms by (auto simp: visit_def)
  then show "L1  L2  {}"
  proof (induction "stl ω" arbitrary: ω rule: suntil_induct_strong)
    case base then show ?case
      by (auto simp add: suntil.simps[of _ _ "stl (stl ω)"] suntil.simps[of _ _ "stl ω"] HLD_iff)
  next
    case step
    show ?case
    proof cases
      assume "((Mix`(L2J))  HLD {End}) (stl ω)"
      with step.hyps show ?thesis
        by (auto simp: inj_Mix HLD_iff elim: suntil.cases)
    next
      assume "¬ ((Mix`(L2J))  HLD {End}) (stl ω)"
      with step.prems have "?U L2 (stl (stl ω))"
        by (auto elim: suntil.cases)
      then show ?thesis
        by (rule step.hyps(4)[OF refl])
    qed
  qed
qed

lemma visit_imp_in_H: "visit {i} J ω  i  H"
  by (auto simp: visit_def HLD_iff)

lemma emeasure_visit:
  assumes I: "I  H" and L: "L  J"
  shows "emeasure 𝔓 {ωspace 𝔓. visit I L ω} = (iI. p_i i) * (card L * p_j)"
proof -
  let ?J = "HLD (Mix`J)" and ?E = "(Mix`L)  HLD {End}"
  let  = "?J aand not ?E"
  let ?P = "λx P. emeasure (T x) {ωspace (T x). P ω}"

  have [intro]: "finite L"
    using finite_J L  J by (blast intro: finite_subset)
  have [simp, intro]: "finite I"
    using finite_J I  H› by (blast intro: finite_subset)

  { fix j assume j: "j  H"
    have "?P (Mix j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f)"
    proof (rule emeasure_suntil_geometric)
      fix s assume s: "s  Mix ` J"
      then have "?P s ?E = (+x. ennreal (1 - p_f) * indicator (Mix`L) x N s)"
        by (auto simp add: emeasure_HLD_nxt emeasure_HLD AE_measure_pmf_iff emeasure_pmf_single
                 split: state.split split_indicator simp del: space_T nxt.simps
                 intro!: nn_integral_cong_AE)
      also have " = ennreal (1 - p_f) * emeasure (N s) (Mix`L)"
        using p_f by (intro nn_integral_cmult_indicator) auto
      also have " = ennreal ((1 - p_f) * card L * p_j * p_f)"
        using s assms
        by (subst emeasure_measure_pmf_finite)
           (auto simp: sum.reindex subset_eq ennreal_mult mult_ac)
      finally show "?P s ?E = p_f * p_j * (1 - p_f) * card L"
        by simp
    next
      show "t. AE ω in T  t. ¬ (?E  (?J  nxt (?J suntil ?E))) ω"
        by (intro AE_I2) (auto simp: HLD_iff elim: suntil.cases)
    qed (insert p_f j, auto simp: emeasure_measure_pmf_finite sum.reindex p_j_def)
    then have "?P (Init j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f) / p_f"
      by (subst emeasure_Init_eq_Mix) (simp_all add:  suntil.simps[of _ _ "x ## s" for x s] divide_ennreal p_f)
    then have "?P (Init j) (?J suntil ?E) = p_j * card L"
      using p_f by simp }
  note J_suntil_E = this

  have "?P Start (visit I L) = (+x. ?P x (?J suntil ?E) * indicator (Init`I) x N Start)"
    unfolding visit_def using I L by (subst emeasure_HLD_nxt) (auto simp: Int_absorb2)
  also have " = (+x. ennreal (p_j * card L) * indicator (Init`I) x N Start)"
    using I J_suntil_E
    by (intro nn_integral_cong ennreal_mult_right_cong)
       (auto split: split_indicator_asm)
  also have " = ennreal ((iI. p_i i) * card L * p_j)"
    using p_j_pos assms
    by (subst nn_integral_cmult_indicator)
       (auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq ennreal_mult[symmetric] sum_nonneg)
  finally show ?thesis by (simp add: ac_simps)
qed

lemma measurable_visit[measurable]: "Measurable.pred S (visit I L)"
  by (simp add: visit_def)

lemma AE_visit: "AE ω in 𝔓. visit H J ω"
proof (rule T.AE_I_eq_1)
  show "emeasure 𝔓 {ωspace 𝔓. visit H J ω} = 1"
    using J_not_empty by (subst emeasure_visit ) (simp_all add: p_j_def)
qed simp

subsection ‹Server gets no information›

lemma server_view1: "j  J  𝒫(ω in 𝔓. visit H {j} ω) = p_j"
  unfolding measure_def by (subst emeasure_visit) simp_all

lemma server_view_indep:
  "L  J  I  H  𝒫(ω in 𝔓. visit I L ω) = 𝒫(ω in 𝔓. visit H L ω) * 𝒫(ω in 𝔓. visit I J ω)"
  unfolding measure_def
  by (subst (1 2 3) emeasure_visit) (auto simp: p_j_def sum_nonneg subset_eq)

lemma server_view: "𝒫(ω in 𝔓. jH. visit {j} {j} ω) = p_j"
  using finite_J
proof (subst T.prob_sum[where I="H" and P="λj. visit {j} {j}"])
  show "(jH. 𝒫(ω in 𝔓. visit {j} {j} ω)) = p_j"
    by (auto simp: measure_def emeasure_visit sum_distrib_right[symmetric] simp del: space_T sets_T)
  show "AE x in 𝔓. (nH. visit {n} {n} x  (jH. visit {j} {j} x)) 
                ((jH. visit {j} {j} x)  (∃!n. n  H  visit {n} {n} x))"
    by (auto dest: visit_unique1)
qed simp_all

subsection ‹Probability that collaborators gain information›

definition "hit_C = Init`H  ev (HLD (Mix`C))"
definition "before_C B = (HLD (Jondo H)) suntil ((Jondo (B  H))  HLD (Mix ` C))"

lemma measurable_hit_C[measurable]: "Measurable.pred S hit_C"
  by (simp add: hit_C_def)

lemma measurable_before_C[measurable]: "Measurable.pred S (before_C B)"
  by (simp add: before_C_def)

lemma before_C:
  assumes ω: "enabled Start ω"
  shows "before_C B ω 
    ((Init`H  (HLD (Mix`H) suntil (Mix`(B  H)  HLD (Mix`C)))) or (Init`(B  H)  HLD (Mix`C))) ω"
proof -
  { fix ω s assume "((HLD (Jondo H)) suntil (Jondo (B  H)  HLD (Mix ` C))) ω"
      "enabled s ω" "s  Jondo H"
    then have "(HLD (Mix ` H) suntil (Mix ` (B  H)  (HLD (Mix ` C)))) ω"
    proof (induction arbitrary: s)
      case (base ω) then show ?case
        by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix intro!: suntil.intros(1))
    next
      case (step ω) from step.prems step.hyps step.IH[of "shd ω"] show ?case
        by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix
                       suntil.simps[of _ _ ω] enabled_End suntil_sconst)
    qed }
  note this[of "stl ω" "shd ω"]
  moreover
  { fix ω s assume "(HLD (Mix ` H) suntil (Mix ` (B  H)  (HLD (Mix ` C)))) ω"
      "enabled s ω" "s  Jondo H"
    then have "((HLD (Jondo H)) suntil ((Jondo (B  H))  HLD (Mix ` C))) ω"
    proof (induction arbitrary: s)
      case (step ω) from step.prems step.hyps step.IH[of "shd ω"] show ?case
        by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix
                       suntil.simps[of _ _ ω] enabled_End suntil_sconst)
    qed (auto intro: suntil.intros simp: HLD_iff) }
  note this[of "stl ω" "shd ω"]
  ultimately show ?thesis
    using assms
    using ‹enabled Start ω
    unfolding before_C_def suntil.simps[of _ _ ω] enabled.simps[of _ ω]
    by (auto simp: E_Start HLD_iff)
qed

lemma before_C_unique:
  assumes ω: "before_C I1 ω" "before_C I2 ω" shows "I1  I2  {}"
  using ω unfolding before_C_def
proof induction
  case (base ω) then show ?case
    by (auto simp add: suntil.simps[of _ _ ω] suntil.simps[of _ _ "stl ω"] HLD_iff)
next
  case (step ω) then show ?case
    by (auto simp add: suntil.simps[of _ _ ω] suntil.simps[of _ _ "stl ω"] HLD_iff)
qed

lemma hit_C_imp_before_C:
  assumes "enabled Start ω" "hit_C ω" shows "before_C H ω"
proof -
  let ?X = "Init`H  Mix`H"
  { fix ω s assume "ev (HLD (Mix`C)) ω" "s?X" "enabled s ω"
    then have "((HLD (Jondo H)) suntil (?X  HLD (Mix ` C))) (s ## ω)"
    proof (induction arbitrary: s rule: ev_induct_strong)
      case (step ω s) from step.IH[of "shd ω"] step.prems step.hyps show ?case
        by (auto simp: enabled.simps[of _ ω] suntil_Stream E_Init E_Mix HLD_iff
          enabled_End ev_sconst)
    qed (auto simp: suntil_Stream) }
  from this[of "stl ω" "shd ω"] assms show ?thesis
    by (auto simp: before_C_def hit_C_def enabled.simps[of _ ω] E_Start)
qed

lemma before_C_single:
  assumes "before_C I ω" shows "iI  H. before_C {i} ω"
  using assms unfolding before_C_def by induction (auto simp: HLD_iff intro: suntil.intros)

lemma before_C_imp_in_H: "before_C {i} ω  i  H"
  by (auto dest: before_C_single)

subsection ‹The probability that the sender hits a collaborator›

lemma Pr_hit_C: "𝒫(ω in 𝔓. hit_C ω) = (1 - p_H) / (1 - p_H * p_f)"
proof -
  let ?P = "λx P. emeasure (T x) {ωspace (T x). P ω}"
  let ?M = "HLD (Mix ` C)" and ?I = "Init`H" and ?J = "Mix`H"
  let  = "(HLD ?J) aand not ?M"

  { fix s assume s: "s  Jondo J"
    have "AE ω in T s. ev ?M ω  (HLD ?J suntil ?M) ω"
      using AE_T_enabled
    proof eventually_elim
      fix ω assume ω: "enabled s ω"
      show "ev ?M ω  (HLD ?J suntil ?M) ω"
      proof
        assume "ev ?M ω"
        from this ω s show "(HLD ?J suntil ?M) ω"
        proof (induct arbitrary: s rule: ev_induct_strong)
          case (step ω) then show ?case
            by (auto simp: HLD_iff enabled.simps[of _ ω] suntil.simps[of _ _ ω] E_End E_Init E_Mix
                           enabled_End ev_sconst)
        qed (auto simp: HLD_iff E_Init intro: suntil.intros)
      qed (rule ev_suntil)
    qed }
  note ev_eq_suntil = this

  have "?P Start hit_C = (+x. ?P x (ev ?M) * indicator ?I x N Start)"
    unfolding hit_C_def by (rule emeasure_HLD_nxt) measurable
  also have " = (+x. ennreal ((1 - p_H) / (1 - p_f * p_H)) * indicator ?I x N Start)"
  proof (intro nn_integral_cong ennreal_mult_right_cong refl)
    fix x assume "indicator (Init ` H) x  0"
    then have "x  ?I"
      by (auto split: split_indicator_asm)
    { fix j assume j: "j  H"
      with ev_eq_suntil[of "Mix j"] have "?P (Mix j) (ev ?M) = ?P (Mix j) ((HLD ?J) suntil ?M)"
        by (intro emeasure_eq_AE) auto
      also have " = (((1 - p_H) * p_f)) / (1 - p_H * p_f)"
      proof (rule emeasure_suntil_geometric)
        fix s assume s: "s  Mix ` H"
        from s C_smaller show "?P s ?M = ennreal ((1 - p_H) * p_f)"
          by (subst emeasure_HLD)
             (auto simp add: emeasure_measure_pmf_finite sum.reindex subset_eq p_j_def H_compl)
        from s show "emeasure (N s) (Mix`H) = p_H * p_f"
          by (auto simp: emeasure_measure_pmf_finite sum.reindex p_H_def p_j_def)
      qed (insert j, auto simp: HLD_iff p_H_p_f_less_1)
      finally have "?P (Init j) (ev ?M) = (1 - p_H) / (1 - p_H * p_f)"
        using p_f
        by (subst emeasure_Init_eq_Mix)
           (auto simp: ev_Stream AE_End ev_sconst HLD_iff mult_le_one divide_ennreal) }
    then show "?P x (ev ?M) = (1 - p_H) / (1 - p_f * p_H)"
      using x  ?I by (auto simp: mult_ac)
  qed
  also have " = ennreal ((1 - p_H) / (1 - p_H * p_f))"
    using p_j_pos p_H p_H_p_f_less_1
    by (subst nn_integral_cmult_indicator)
       (auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq mult_ac
             intro!: divide_nonneg_nonneg)
  finally show ?thesis
    by (simp add: measure_def mult_le_one)
qed

lemma before_C_imp_hit_C:
  assumes "enabled Start ω" "before_C B ω"
  shows "hit_C ω"
proof -
  { fix ω j assume "((HLD (Jondo H)) suntil (Jondo (B  H)  HLD (Mix ` C))) ω"
      "j  H" "enabled (Mix j) ω"
    then have "ev (HLD (Mix`C)) ω"
    proof (induction arbitrary: j rule: suntil_induct_strong)
      case (step ω) then show ?case
        by (auto simp: enabled.simps[of _ ω] E_Mix enabled_End ev_sconst suntil_sconst HLD_iff)
    qed auto }
  from this[of "stl (stl ω)"] assms show "hit_C ω"
    by (force simp: before_C_def hit_C_def E_Start HLD_iff E_Init
      enabled.simps[of _ ω] ev.simps[of _ ω] suntil.simps[of _ _ ω]
      enabled.simps[of _ "stl ω"] ev.simps[of _ "stl ω"] suntil.simps[of _ _ "stl ω"])
qed

lemma negE: "¬ P  P  False"
  by blast

lemma Pr_visit_before_C:
  assumes L: "L  H" and I: "I  H"
  shows "𝒫(ω in 𝔓. visit I J ω  before_C L ω ¦ hit_C ω ) =
    (iI. p_i i) * card L * p_j * p_f + (iI  L. p_i i) * (1 - p_H * p_f)"
proof -
  let ?M = "Mix`H"
  let ?P = "λx P. emeasure (T x) {ωspace (T x). P ω}"
  let ?V = "(visit I J aand before_C L) aand hit_C"
  let ?U = "HLD ?M suntil (Mix`L  HLD (Mix`C))"
  let ?L = "HLD (Mix`C)"

  have IJ: "x  I  x  J" for x
    using I by auto

  have [simp, intro]: "finite I" "finite L"
    using L I by (auto dest: finite_subset)

  have "?P Start ?V = ?P Start ((Init`I  ?U) or (Init`(I  L)  ?L))"
  proof (rule emeasure_Collect_eq_AE)
    show "AE ω in 𝔓. ?V ω  ((Init`I  ?U) or (Init`(I  L)  ?L)) ω"
      using AE_T_enabled AE_visit
    proof eventually_elim
      case (elim ω)
      then show ?case
        using before_C_imp_hit_C[of ω "L"]  before_C[of ω "L"] I L
        by (auto simp: visit_def HLD_iff Int_absorb2)
    qed
    show "Measurable.pred 𝔓 ((Init`I  ?U) or (Init`(I  L)  ?L))"
      by measurable
  qed measurable
  also have " = ?P Start (Init`I  ?U) + ?P Start (Init`(I  L)  ?L)"
    using L I
    apply (subst plus_emeasure)
    apply (auto intro!: arg_cong2[where f=emeasure])
    apply (subst (asm) suntil.simps)
    apply (auto simp add: HLD_iff[abs_def] elim: suntil.cases)
    done
  also have "?P Start (Init`(I  L)  ?L) = (iIL. p_i i * (1 - p_H))"
    using L I C_smaller p_j_pos
    apply (subst emeasure_HLD_nxt emeasure_HLD, simp)+
    apply (subst nn_integral_indicator_finite)
    apply (auto simp: emeasure_measure_pmf_finite sum.reindex next_prob_def sum.If_cases
                      Int_absorb2 H_compl2 ennreal_mult[symmetric] sum_nonneg
                      sum_distrib_left[symmetric] sum_distrib_right[symmetric]
                intro!: sum.cong sum_nonneg)
    apply (subst (asm) ennreal_inj)
    apply (auto intro!: mult_nonneg_nonneg sum_nonneg sum.mono_neutral_left elim!: negE)
    done
  also have "?P Start (Init`I  ?U) = (iI. ?P (Init i) ?U * p_i i)"
    using I
    by (subst emeasure_HLD_nxt, simp)
       (auto simp: nn_integral_indicator_finite sum.reindex emeasure_measure_pmf_finite
             intro!: sum.cong[OF refl])
  also have " = (iI. ennreal (p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)) * p_i i)"
  proof (intro sum.cong refl arg_cong2[where f="(*)"])
    fix i assume "i  I"
    with I have i: "i  H"
      by auto
    have "?P (Mix i) ?U = (p_f * p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f))"
      unfolding before_C_def
    proof (rule emeasure_suntil_geometric[where X="?M"])
      show "Mix i  ?M"
        using i by auto
    next
      fix s assume "s  ?M"
      with p_f p_j_pos L C_smaller[THEN less_imp_le]
      show "?P s (Mix`L  (HLD (Mix ` C))) = ennreal (p_f * p_f * (1 - p_H) * p_j * card L)"
        apply (simp add: emeasure_HLD emeasure_HLD_nxt del: nxt.simps space_T)
        apply (subst nn_integral_measure_pmf_support[of "Mix`L"])
        apply (auto simp add: subset_eq emeasure_measure_pmf_finite sum.reindex H_compl p_j_def
          ennreal_mult[symmetric] ennreal_of_nat_eq_real_of_nat)
        done
    next
      fix s assume "s  ?M" then show "emeasure (N s) ?M = ennreal (p_H * p_f)"
        by (auto simp add: emeasure_measure_pmf_finite sum.reindex H_eq2)
    next
      show "AE ω in T t. ¬ ((Mix ` L  ?L)  (HLD (Mix ` H)  nxt ?U)) ω" for t
        using L
        apply (simp add: AE_T_iff[of _ t])
        apply (subst AE_T_iff; simp)
        apply (auto simp: HLD_iff suntil_Stream)
        done
    qed (insert L, auto simp: p_H_p_f_less_1 E_Mix)
    then show "?P (Init i) ?U = p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)"
      by (subst emeasure_Init_eq_Mix)
         (auto simp: AE_End suntil_Stream divide_ennreal mult_le_one p_f)
  qed
  finally have *: "𝒫(ω in T Start. ?V ω) =
      (p_f * (1 - p_H) * p_j * (card L) / (1 - p_H * p_f)) * (iI. p_i i) +
      (iI  L. p_i i) * (1 - p_H)"
    using sum_nonneg [of "I  L" p_i]  sum_nonneg [of "I" p_i]
    by (simp add: mult_ac measure_def sum_distrib_right[symmetric] sum_distrib_left[symmetric]
                  sum_divide_distrib[symmetric] IJ ennreal_mult[symmetric] 
                  mult_le_one ennreal_plus[symmetric]
             del: ennreal_plus)
  show ?thesis
    unfolding cond_prob_def Pr_hit_C *
    using *
    using p_f p_H p_j_pos p_H_p_f_less_1 by (simp add: divide_simps) (simp add: field_simps)
qed

lemma Pr_visit_eq_before_C:
  "𝒫(ω in 𝔓. jH. visit {j} J ω  before_C {j} ω ¦ hit_C ω ) = 1 - (p_H - p_j) * p_f"
proof -
  let ?V = "λj. visit {j} J aand before_C {j}" and ?H = "hit_C"
  let ?J = "H"
  have "𝒫(ω in 𝔓. (j?J. ?V j ω)  ?H ω) = (j?J. 𝒫(ω in 𝔓. (?V j aand ?H) ω))"
  proof (rule T.prob_sum)
    show "AE ω in 𝔓. (j?J. (?V j aand ?H) ω  ((j?J. ?V j ω)  ?H ω)) 
      (((j?J. ?V j ω)  ?H ω)  (∃!j. j?J  (?V j aand ?H) ω))"
      by (auto intro!: AE_I2 dest: visit_unique1)
  qed auto
  then have "𝒫(ω in 𝔓. (j?J. ?V j ω) ¦ ?H ω) = (j?J. 𝒫(ω in 𝔓. ?V j ω ¦ ?H ω))"
    by (simp add: cond_prob_def sum_divide_distrib)
  also have " = p_j * p_f + (1 - p_H * p_f)"
    by (simp add: Pr_visit_before_C sum_distrib_right[symmetric] sum.distrib)
  finally show ?thesis
    by (simp add: field_simps)
qed

lemma probably_innocent:
  assumes approx: "1 / (2 * (p_H - p_j))  p_f" and "p_H  p_j"
  shows "𝒫(ω in 𝔓. jH. visit {j} J ω  before_C {j} ω ¦ hit_C ω )  1 / 2"
  unfolding Pr_visit_eq_before_C
proof -
  have [simp]: "n :: nat. 1  real n  1  n" by auto
  have "0  p_j" unfolding p_j_def by auto
  then have "1 * p_j  p_H"
    unfolding H_eq2[symmetric] using C_smaller
    by (intro mult_mono) (auto simp: Suc_le_eq card_Diff_subset not_le)
  with ‹p_H  p_j› have "p_j < p_H" by auto
  with approx show "1 - (p_H - p_j) * p_f  1 / 2"
    by (auto simp add: field_simps divide_le_eq split: if_split_asm)
qed

lemma Pr_before_C:
  assumes L: "L  H"
  shows "𝒫(ω in 𝔓. before_C L ω ¦ hit_C ω ) =
    card L * p_j * p_f + (lL. p_i l) * (1 - p_H * p_f)"
proof -
  have "𝒫(ω in 𝔓. before_C L ω ¦ hit_C ω ) =
    𝒫(ω in 𝔓. visit H J ω  before_C L ω ¦ hit_C ω )"
    using AE_visit by (auto intro!: T.cond_prob_eq_AE)
  also have " = card L * p_j * p_f + (iL. p_i i) * (1 - p_H * p_f)"
    using L by (subst Pr_visit_before_C[OF L order_refl]) (auto simp: Int_absorb1)
  finally show ?thesis .
qed

lemma P_visit:
  assumes I: "I  H"
  shows "𝒫(ω in 𝔓. visit I J ω ¦ hit_C ω ) = (iI. p_i i)"
proof -
  have "𝒫(ω in 𝔓. visit I J ω ¦ hit_C ω ) =
    𝒫(ω in 𝔓. visit I J ω  before_C H ω ¦ hit_C ω )"
  proof (rule T.cond_prob_eq_AE)
    show "AE x in 𝔓. hit_C x 
                visit I J x = (visit I J x  before_C H x)"
      using AE_T_enabled by eventually_elim (auto intro: hit_C_imp_before_C)
  qed auto
  also have " = sum p_i I"
    using I by (subst Pr_visit_before_C[OF order_refl]) (auto simp: Int_absorb2 field_simps p_H_def p_j_def)
  finally show ?thesis .
qed

subsection ‹Probability space of hitting a collaborator›

definition "hC = uniform_measure 𝔓 {ωspace 𝔓. hit_C ω}"

lemma emeasure_hit_C_not_0: "emeasure 𝔓 {ω  space 𝔓. hit_C ω}  0"
  using p_H p_H_p_f_less_1 unfolding Pr_hit_C T.emeasure_eq_measure by auto

lemma measurable_hC[measurable (raw)]:
  "A  sets S  A  sets hC"
  "f  measurable M S  f  measurable M hC"
  "g  measurable S M  g  measurable hC M"
  "A  space S  sets S  A  space hC  sets S"
  unfolding hC_def uniform_measure_def
  by simp_all

lemma vimage_Int_space_C[simp]:
  "f -` {x}  space hC = {ωspace S. f ω = x}"
  by (auto simp: hC_def)

sublocale hC: information_space hC 2
proof -
  interpret hC: prob_space hC
    unfolding hC_def
    using emeasure_hit_C_not_0
    by (intro prob_space_uniform_measure) auto
  show "information_space hC 2"
    by standard simp
qed

abbreviation
  mutual_information_Pow_CP ("ℐ'(_ ; _')") where
  "ℐ(X ; Y)  hC.mutual_information 2 (count_space (X`space hC)) (count_space (Y`space hC)) X Y"

lemma simple_functionI:
  assumes "finite (range f)"
  assumes [measurable]: "x. {ωspace S. f ω = x}  sets S"
  shows "simple_function hC f"
  using assms unfolding simple_function_def hC_def
  by (simp add: vimage_def space_stream_space)

subsection ‹Estimate the information to the collaborators›

lemma measure_hC[simp]:
  assumes A[measurable]: "A  sets S"
  shows "measure hC A = 𝒫(ω in 𝔓. ω  A ¦ hit_C ω )"
  unfolding hC_def cond_prob_def
  using emeasure_hit_C_not_0 A
  by (subst measure_uniform_measure) (simp_all add: T.emeasure_eq_measure Int_def conj_ac)

subsubsection ‹Setup random variables for mutual information›

definition "first_J ω = (THE i. visit {i} J ω)"

lemma first_J_eq:
  "visit {i} J ω  first_J ω = i"
  unfolding first_J_def by (intro the_equality) (auto dest: visit_unique1)

lemma AE_first_J:
  "AE ω in 𝔓. visit {i} J ω  first_J ω = i"
  using AE_visit
proof eventually_elim
  fix ω assume "visit H J ω"
  then obtain j where "visit {j} J ω" "j  H"
    by (auto simp: visit_def HLD_iff)
  then show "visit {i} J ω  first_J ω = i"
    by (auto dest: visit_unique1 first_J_eq)
qed

lemma measurbale_first_J[measurable]: "first_J  measurable S (count_space UNIV)"
  unfolding first_J_def[abs_def]
  by (intro measurable_THE[where I=H])
     (auto dest: visit_imp_in_H visit_unique1 intro: countable_finite)

definition "last_H ω = (THE i. before_C {i} ω)"

lemma measurbale_last_H[measurable]: "last_H  measurable S (count_space UNIV)"
  unfolding last_H_def[abs_def]
  by (intro measurable_THE[where I=H])
     (auto dest: before_C_single before_C_unique intro: countable_finite)

lemma last_H_eq:
  "before_C {i} ω  last_H ω = i"
  unfolding last_H_def by (intro the_equality) (auto dest: before_C_unique)

lemma last_H:
  assumes "enabled Start ω" "hit_C ω"
  shows "before_C {last_H ω} ω" "last_H ω  H"
  by (metis before_C_single hit_C_imp_before_C last_H_eq Int_iff assms)+

lemma AE_last_H:
  "AE ω in 𝔓. hit_C ω  before_C {i} ω  last_H ω = i"
  using AE_T_enabled
proof eventually_elim
  fix ω assume "enabled Start ω" then show "hit_C ω  before_C {i} ω = (last_H ω = i)"
    by (auto dest: last_H last_H_eq)
qed

lemma information_flow:
  defines "h  real (card H)"
  assumes init_uniform: "i. i  H  p_i i = 1 / h"
  shows "ℐ(first_J ; last_H)  (1 - (h - 1) * p_j * p_f) * log 2 h"
proof -
  let ?il = "λi l. 𝒫(ω in 𝔓. visit {i} J ω  before_C {l} ω ¦ hit_C ω )"
  let ?i = "λi. 𝒫(ω in 𝔓. visit {i} J ω ¦ hit_C ω )"
  let ?l = "λl. 𝒫(ω in 𝔓. before_C {l} ω ¦ hit_C ω )"

  from init_uniform have init_H: "i. i  H  p_i i = p_j / p_H"
    by (simp add: p_j_def p_H_def h_def)

  from h_def have "1/h = p_j/p_H" "h = p_H / p_j" "p_H = h * p_j"
    by (auto simp: p_H_def p_j_def field_simps)
  from C_smaller have h_pos: "0 < h"
    by (auto simp add: card_gt_0_iff h_def)

  let ?s = "(h - 1) * p_j"
  let ?f = "?s * p_f"

  from psubset_card_mono[OF _ C_smaller]
  have "1  card J - card C"
    by (simp del: C_le_J)
  then have "1  h"
    using C_smaller
    by (simp add: h_def card_Diff_subset card_mono field_simps del: C_le_J)

  have log_le_0: "?f * log 2 (p_H * p_f)  ?f * log 2 1"
    using p_H_p_f_less_1 p_H_p_f_pos p_j_pos p_f 1  h
    by (intro mult_left_mono log_le mult_nonneg_nonneg) auto

  have "(h - 1) * p_j < 1"
    using 1  h C_smaller
    by (auto simp: h_def p_j_def divide_less_eq card_Diff_subset card_mono)
  then have 1: "(h - 1) * p_j * p_f < 1 * 1"
    using p_f by (intro mult_strict_mono) auto

  { fix ω have "first_J ω  H  first_J ω = (THE x. False)"
      apply (cases "i. ¬ visit {i} J ω")
      apply (simp add: first_J_def)
      apply (auto dest: visit_imp_in_H first_J_eq)
      done }
  then have range_fj: "range first_J  H  {THE x. False}"
    by auto

  have sf_fj: "simple_function hC first_J"
    by (rule simple_functionI) (auto intro: finite_subset[OF range_fj])

  have sd_fj: "simple_distributed hC first_J ?i"
    apply (rule hC.simple_distributedI[OF sf_fj])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_first_J
    apply eventually_elim
    apply auto
    done

  { fix ω have "last_H ω  H  last_H ω = (THE x. False)"
      apply (cases "i. ¬ before_C {i} ω")
      apply (simp add: last_H_def)
      apply (auto dest: before_C_imp_in_H last_H_eq)
      done }
  then have range_lnc: "range last_H  H  {THE x. False}"
    by auto

  have sf_lnc: "simple_function hC last_H"
    by (rule simple_functionI) (auto intro: finite_subset[OF range_lnc])

  have sd_lnc: "simple_distributed hC last_H ?l"
    apply (rule hC.simple_distributedI[OF sf_lnc])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_last_H
    apply eventually_elim
    apply auto
    done

  have sd_fj_lnc: "simple_distributed hC (λω. (first_J ω, last_H ω)) (λ(i, l). ?il i l)"
    apply (rule hC.simple_distributedI)
    apply (rule simple_function_Pair[OF sf_fj sf_lnc])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_last_H AE_first_J
    apply eventually_elim
    apply auto
    done

  define c where "c = (SOME j. j  C)"
  have c: "c  C"
    using C_non_empty unfolding ex_in_conv[symmetric] c_def by (rule someI_ex)

  let ?inner = "λi. lH. ?il i l * log 2 (?il i l / (?i i * ?l l))"
  { fix i assume i: "i  H"
    with h_pos have card_idx: "real_of_nat (card (H - {i})) = p_H / p_j - 1"
      by (auto simp add: p_j_def p_H_def h_def)

    have neq0: "p_j  0" "p_H  0"
      unfolding p_j_def p_H_def
      using C_smaller i by auto

    from i have "?inner i =
      (lH - {i}. ?il i l * log 2 (?il i l / (?i i * ?l l))) +
      ?il i i * log 2 (?il i i / (?i i * ?l i))"
      by (simp add: sum_diff)
    also have " =
      (lH - {i}. p_j/p_H * p_j * p_f * log 2 (p_j * p_f / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))) +
      p_j/p_H * (p_j * p_f + (1 - p_H * p_f)) * log 2 ((p_j * p_f + (1 - p_H * p_f)) / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))"
      using i p_f p_j_pos p_H
      apply (simp add: Pr_visit_before_C P_visit init_H Pr_before_C
                  del: sum_constant)
      apply (simp add: divide_simps distrib_left)
      apply (intro arg_cong2[where f="(*)"] refl arg_cong2[where f=log])
      apply (auto simp: field_simps)
      done
    also have " = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h"
      using neq0 p_f by (simp add: card_idx field_simps ‹p_H = h * p_j›)
    finally have "?inner i = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h" . }
  then have "(iH. ?inner i) = ?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
    using h_pos by (simp add: h_def[symmetric])
  also have " = ?f * log 2 (p_H * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
    by (simp add: h = p_H / p_j›)
  also have "  (1 - ?f) * log 2 ((1 - ?f) * h)"
    using log_le_0 by simp
  also have "  (1 - ?f) * log 2 h"
    using h_pos 1  h 1 p_j_pos p_f
    by (intro mult_left_mono log_le mult_pos_pos mult_nonneg_nonneg) auto
  finally have "(iH. ?inner i)  (1 - ?f) * log 2 h" .
  also have "(iH. ?inner i) =
      ((i, l)(first_J`space S) × (last_H`space S). ?il i l * log 2 (?il i l / (?i i * ?l l)))"
    unfolding sum.cartesian_product
  proof (safe intro!: sum.mono_neutral_cong_left del: DiffE DiffI)
    show "finite ((first_J ` space S) × (last_H ` space S))"
      using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
  next
    fix i assume "i  H"
    then have "visit {i} J (Init i ## Mix i ## sconst End)"
      "before_C {i} (Init i ## Mix c ## sconst End)"
      by (auto simp: before_C_def visit_def suntil_Stream HLD_iff c)
    then show "i  first_J ` space S" "i  last_H ` space S"
      by (auto simp: space_stream_space image_iff eq_commute dest!: first_J_eq last_H_eq)
  next
    fix i l assume "(i, l)  first_J ` space S × last_H ` space S - H × H"
    then have H: "i  H  l  H"
      by auto
    have "𝒫(ω in 𝔓. (visit {i} J ω  before_C {l} ω)  hit_C ω) = 0"
      using H by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
    then show "?il i l * log 2 (?il i l / (?i i * ?l l)) = 0"
      by (simp add: cond_prob_def)
  qed
  also have " = ℐ(first_J ; last_H)"
    unfolding sum.cartesian_product
    apply (subst hC.mutual_information_simple_distributed[OF sd_fj sd_lnc sd_fj_lnc])
    apply (simp add: hC_def)
  proof (safe intro!: sum.mono_neutral_right imageI)
    show "finite ((first_J ` space S) × (last_H ` space S))"
      using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
  next
    fix i l assume "(first_J i, last_H l)  (λx. (first_J x, last_H x)) ` space S"
    moreover
    { fix i l assume "i  H" "l  H"
      then have "visit {i} J (Init i ## Mix l ## Mix c ## sconst End)"
        "before_C {l} (Init i ## Mix l ## Mix c ## sconst End)"
        using c C_smaller by (auto simp: before_C_def visit_def HLD_iff suntil_Stream)
      then have "first_J (Init i ## Mix l ## Mix c ## sconst End) = i"
        "last_H (Init i ## Mix l ## Mix c ## sconst End) = l"
        by (auto intro!: first_J_eq last_H_eq) }
    note this[of "first_J i" "last_H l"]
    ultimately have "(first_J i, last_H l)  H×H"
      by (auto simp: space_stream_space image_iff eq_commute) metis
    then have "𝒫(ω in 𝔓. (visit {first_J i} J ω  before_C {last_H l} ω)  hit_C ω) = 0"
      by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
    then show "?il (first_J i) (last_H l) *
      log 2 (?il (first_J i) (last_H l) / (?i (first_J i) * ?l (last_H l))) = 0"
      by (simp add: cond_prob_def)
  qed
  finally show ?thesis by simp
qed

end

end

Theory Zeroconf_Analysis

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Formalizing the IPv4-address allocation in ZeroConf›

theory Zeroconf_Analysis
  imports "../Discrete_Time_Markov_Chain"
begin

declare UNIV_bool[simp]

subsection ‹Definition of a ZeroConf allocation run›

datatype zc_state = start
                  | probe nat
                  | ok
                  | error

lemma inj_probe: "inj_on probe X"
  by (auto simp: inj_on_def)

text ‹Countability of @{typ zc_state} simplifies measurability of functions on @{typ zc_state}.›

instance zc_state :: countable
proof
  have "countable ({start, ok, error}  probe`UNIV)"
    by auto
  also have "{start, ok, error}  probe`UNIV = UNIV"
    using zc_state.nchotomy by auto
  finally show "f::zc_state  nat. inj f"
    using inj_on_to_nat_on[of "UNIV :: zc_state set"] by auto
qed

locale Zeroconf_Analysis =
  fixes N :: nat and p q r e :: real
  assumes p: "0 < p" "p < 1" and q: "0 < q" "q < 1"
  assumes r[simp]: "0  r" and e[simp]: "0  e"
begin

lemma p_bounds[simp]: "0  p" "p  1"
  using p by auto

lemma q_bounds[simp]: "0  q" "q  1"
  using q by auto

abbreviation states where
  "states  probe ` {.. N}  {start, ok, error}"

primrec τ :: "zc_state  zc_state pmf" where
  "τ start     = map_pmf (λTrue  probe 0 | False  ok) (bernoulli_pmf q)"
| "τ (probe n) = map_pmf (λTrue  (if n < N then probe (Suc n) else error) | False  start) (bernoulli_pmf p)"
| "τ ok        = return_pmf ok"
| "τ error     = return_pmf error"

primrec ρ :: "zc_state  zc_state  real" where
  "ρ start     = (λ_. 0) (probe 0 := r, ok := r * (N + 1))"
| "ρ (probe n) = (if n < N then (λ_. 0) (probe (Suc n) := r) else (λ_. 0) (error := e))"
| "ρ ok        = (λ_. 0) (ok := 0)"
| "ρ error     = (λ_. 0) (error := 0)"

lemma ρ_nonneg'[simp]: "0  ρ s t"
  using r e by (cases s) auto

sublocale MC_with_rewards τ ρ "λs. 0"
  proof qed (simp_all add: pair_measure_countable)

subsection ‹The allocation run is a rewarded DTMC›

abbreviation "E s  set_pmf (τ s)"

lemma enabled_ok: "enabled ok ω  ω = sconst ok"
  by (simp add: enabled_iff_sconst)

lemma finite_E[intro, simp]: "finite (E s)"
  by (cases s) auto

lemma E_closed: "s  states  E s  states"
  using p q by (cases s) (auto split: bool.splits)

lemma enabled_error: "enabled error ω  ω = sconst error"
  by (simp add: enabled_iff_sconst)

lemma pos_neg_q_pn: "0 < 1 - q * (1 - p^Suc N)"
proof -
  have "p ^ Suc N  1 ^ Suc N"
    using p by (intro power_mono) auto
  with p q have "q * (1 - p^Suc N) < 1 * 1"
    by (intro mult_strict_mono) (auto simp: field_simps simp del: power_Suc)
  then show ?thesis by simp
qed

lemma to_error: assumes "n  N" shows "(probe n, error)  acc"
  using n  N
proof (induction rule: inc_induct)
  case (step n') with p show ?case
    by (intro rtrancl_trans[OF r_into_rtrancl step.IH]) auto
qed (insert p, auto)

subsection ‹Probability of a erroneous allocation›

definition "P_err s = 𝒫(ω in T s. ev (HLD {error}) (s ## ω))"

lemma P_err:
  defines "p_start == (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  defines "p_probe == (λn. p ^ Suc (N - n) + (1 - p^Suc (N - n)) * p_start)"
  assumes s: "s  states - {ok, error}"
  shows "P_err s = (case s of ok  0 | error  1 | probe n  p_probe n | start  p_start)"
    (is " = ?E s")
  using s
proof (rule unique_les)
  have [arith]: "0  p * (q * p ^ N)"
    using p q by simp
  have p_eq: "p_start = p_probe 0 * q"
    "n. n < N  p_probe n = p_probe (Suc n) * p + p_start * (1 - p)"
    "p_probe N = p + p_start * (1 - p)"
    using p q
    by (auto simp: p_probe_def p_start_def power_Suc[symmetric] Suc_diff_Suc divide_simps
             simp del: power_Suc)
       (auto simp: field_simps)
  fix s assume s: "s  states - {ok, error}"
  then show "?E s = (t. ?E t τ s) + 0"
    using p q by (auto intro: p_eq)
  show "t{ok, error}. (s, t)  acc"
    using s q to_error by auto
  from s show "P_err s = integralL (measure_pmf (τ s)) P_err + 0"
    unfolding P_err_def[abs_def] by (subst prob_T) (auto simp: ev_Stream simp del: UNIV_bool)
next
  fix s assume "s  {ok, error}" then show "P_err s = ?E s"
    by (auto intro!: T.prob_eq_0_AE T.prob_Collect_eq_1[THEN iffD2]
             simp: P_err_def AE_sconst ev_sconst HLD_iff ev_Stream T.prob_space
             simp del: space_T sets_T )
qed (insert p q, auto intro!: integrable_measure_pmf_finite split: if_split_asm)

lemma P_err_start: "P_err start = (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  by (simp add: P_err)

subsection ‹An allocation run terminates almost surely›

lemma states_closed:
  assumes "s  states"
  assumes "(s, t)  acc_on (- {error, ok})"
  shows "t  states"
  using assms(2,1) p q by induction (auto split: if_split_asm)

lemma finite_reached:
  assumes s: "s  states" shows "finite (acc_on (- {error, ok}) `` {s})"
  using states_closed[OF s]
  by (rule_tac finite_subset[of _ states]) auto

lemma AE_reaches_error_or_ok:
  assumes s: "s  states"
  shows "AE ω in T s. ev (HLD {error, ok}) ω"
proof (rule AE_T_ev_HLD)
  { fix t assume t: "(s, t)  acc_on (- {error, ok})"
    with states_closed[OF s t] to_error p q show "t'{error, ok}. (t, t')  acc"
      by auto }
qed (rule finite_reached[OF s])

subsection ‹Expected runtime of an allocation run›

definition "R s = (+ ω. reward_until {error, ok} s ω T s)"

definition "R' s = enn2real (R s)"

lemma R_iter: "s  error  s  ok  R s = (+t. ennreal (ρ s t) + R t τ s)"
  unfolding R_def using T.emeasure_space_1
  by (subst nn_integral_T)
     (auto simp del: τ.simps ρ.simps simp add: AE_measure_pmf_iff nn_integral_add
           intro!: nn_integral_cong_AE)

lemma R_finite:
  assumes s: "s  states"
  shows "R s  "
  unfolding R_def
proof (rule nn_integral_reward_until_finite)
  { fix t assume "(s, t)  acc" from this s p q have "t  states"
      by induction (auto split: if_split_asm) }
  then have "acc `` {s}  states"
    by auto
  then show "finite (acc `` {s})"
    by (auto dest: finite_subset)
qed (auto simp: AE_reaches_error_or_ok[OF s])

lemma R_less_top: "s  states  R s < top"
  using R_finite[of s] by (subst less_top[symmetric]) simp

lemma R'_iter: assumes s: "s  states" "s  error" "s  ok" shows "R' s = (t. ρ s t + R' t τ s)"
  unfolding R'_def R_iter[OF s(2,3)]
proof (rule enn2real_nn_integral_eq_integral)
  have "t  E s  R t < top" for t
    using sstates› E_closed[of s] by (intro R_less_top) auto
  then show "AE t in τ s. ennreal (ρ s t) + R t = ennreal (ρ s t + enn2real (R t))"
    by (auto simp: AE_measure_pmf_iff intro!: ennreal_enn2real[symmetric])
  show "(+ t. ennreal (ρ s t) + R t τ s) < "
    unfolding R_iter[symmetric, OF s(2,3)] by (rule R_less_top) fact
qed auto

lemma cost_from_start:
  "R' start =
    (q * (r + p^Suc N * e + r * p * (1 - p^N) / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q + q * p^Suc N)"
proof -
  have ok_error: "R' ok = 0  R' error = 0"
    unfolding R'_def R_def by (subst (1 2) reward_until_unfold[abs_def]) simp

  then have R_start: "R' start = q * (r + R' (probe 0)) + (1 - q) * (r * (N + 1))"
    using q r by (subst R'_iter) (simp_all add: field_simps)

  have R_probe: "n. n < N  R' (probe n) = p * R' (probe (Suc n)) + p * r + (1 - p) * R' start"
    using p r by (subst R'_iter) (simp_all add: field_simps distrib_right)

  have R_N: "R' (probe N) = p * e + (1 - p) * R' start"
    using p e ok_error by (subst R'_iter) (auto simp: mult.commute )

  { fix n
    assume "n  N"
    then have "R' (probe (N - n)) =
      p ^ Suc n * e + (1 - p^n) * r * p / (1 - p) + (1 - p^Suc n) * R' start"
    proof (induct n)
      case 0 with R_N show ?case by simp
    next
      case (Suc n)
      moreover then have "Suc (N - Suc n) = N - n" by simp
      ultimately show ?case
        using R_probe[of "N - Suc n"] p by (simp_all add: field_simps Suc)
    qed }
  from this[of N]
  have [simp]: "R' (probe 0) = p ^ Suc N * e + (1 - p^N) * r * p / (1 - p) + (1 - p^Suc N) * R' start"
    by simp
  have "R' start - q * (1 - p^Suc N) * R' start =
    q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * (N + 1))"
    by (subst R_start) (simp_all add: field_simps)
  then have "R' start = (q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q * (1 - p^Suc N))"
    using pos_neg_q_pn by (simp_all add: field_simps)
  then show ?thesis
    by (simp add: field_simps)
qed

end

interpretation ZC: Zeroconf_Analysis 2 "16 / 65024 :: real" "0.01" "0.002" "3600"
  by standard auto

lemma "ZC.P_err start  1 / 10^12"
  unfolding ZC.P_err_start by (simp add: power_divide power_one_over[symmetric])

lemma "ZC.R' start  0.007"
  unfolding ZC.cost_from_start by (simp add: power_divide power_one_over[symmetric])

end

Theory Gossip_Broadcast

(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section ‹Formalization of the Gossip-Broadcast›

theory Gossip_Broadcast
  imports "../Discrete_Time_Markov_Chain"
begin

lemma inj_on_upd_PiE:
  assumes "i  I" shows "inj_on (λ(x,f). f(i := x)) (M × (ΠE iI. A i))"
  unfolding PiE_def
proof (safe intro!: inj_onI ext)
  fix f g :: "'a  'b" and x y :: 'b
  assume *: "f(i := x) = g(i := y)" "f  extensional I" "g  extensional I"
  then show "x = y" by (auto simp: fun_eq_iff split: if_split_asm)
  fix i' from * i  I show "f i' = g i'"
    by (cases "i' = i") (auto simp: fun_eq_iff extensional_def split: if_split_asm)
qed

lemma sum_folded_product:
  fixes I :: "'i set" and f :: "'s  'i  'a::{semiring_0, comm_monoid_mult}"
  assumes "finite I" "i. i  I  finite (S i)"
  shows "(xPiE I S. iI. f (x i) i) = (iI. sS i. f s i)"
using assms proof (induct I)
  case empty then show ?case by simp
next
  case (insert i I)
  have *: "PiE (insert i I) S = (λ(x, f). f(i := x)) ` (S i × PiE I S)"
    by (auto simp: PiE_def intro!: image_eqI ext dest: extensional_arb)
  have "(xPiE (insert i I) S. iinsert i I. f (x i) i) =
    sum ((λx. iinsert i I. f (x i) i)  ((λ(x, f). f(i := x)))) (S i × PiE I S)"
    unfolding * using insert by (intro sum.reindex) (auto intro!: inj_on_upd_PiE)
  also have " = ((a, x)(S i × PiE I S). f a i * (iI. f (x i) i))"
    using insert by (force intro!: sum.cong prod.cong arg_cong2[where f="(*)"])
  also have " = (aS i. f a i * (xPiE I S. iI. f (x i) i))"
    by (simp add: sum.cartesian_product sum_distrib_left)
  finally show ?case
    using insert by (simp add: sum_distrib_right)
qed

subsection ‹Definition of the Gossip-Broadcast›

datatype state = listening | sending | sleeping

type_synonym sys_state = "(nat × nat)  state"

lemma state_UNIV: "UNIV = {listening, sending, sleeping}"
  by (auto intro: state.exhaust)

locale gossip_broadcast =
  fixes size :: nat and p :: real
  assumes size: "0 < size"
  assumes p: "0 < p" "p < 1"
begin

interpretation pmf_as_function .

definition states :: "sys_state set" where
  "states = ({..< size} × {..< size}) E {listening, sending, sleeping}"

definition start :: sys_state where
  "start = (λx{..< size}×{..< size}. listening)((0, 0) := sending)"

definition neighbour_sending where
  "neighbour_sending s = (λ(x,y).
    (x > 0  s (x - 1, y) = sending) 
    (x < size  s (x + 1, y) = sending) 
    (y > 0  s (x, y - 1) = sending) 
    (y < size  s (x, y + 1) = sending))"

definition node_trans :: "sys_state  (nat × nat)  state  state  real" where
"node_trans g x s = (case s of
  listening  (if neighbour_sending g x
    then (λ_.0) (sending := p, sleeping := 1 - p)
    else (λ_.0) (listening := 1))
| sending    (λ_.0) (sleeping := 1)
| sleeping   (λ_.0) (sleeping := 1))"

lemma node_trans_sum_eq_1[simp]:
  "node_trans g x s' listening + (node_trans g x s' sending + node_trans g x s' sleeping) = 1"
  by (simp add: node_trans_def split: state.split)

lemma node_trans_nonneg[simp]: "0  node_trans s x i j"
  using p by (auto simp: node_trans_def split: state.split)

lift_definition proto_trans :: "sys_state  sys_state pmf" is
  "λs s'. if s'  states then (x{..< size}×{..< size}. node_trans s x (s x) (s' x)) else 0"
proof
  let ?f = "λs s'. if s'  states then (x{..< size}×{..< size}. node_trans s x (s x) (s' x)) else 0"
  fix s show "t. 0  ?f s t"
    using p by (auto intro!: prod_nonneg simp: node_trans_def split: state.split)
  show "(+t. ?f s t count_space UNIV) = 1"
    apply (subst nn_integral_count_space'[of states])
    apply (simp_all add: prod_nonneg)
  proof -
    show "(xstates. xa{..<size} × {..<size}. node_trans s xa (s xa) (x xa)) = 1"
      unfolding states_def by (subst sum_folded_product) simp_all
    show "finite states"
      by (auto simp: states_def intro!: finite_PiE)
  qed
qed

end

subsection ‹The Gossip-Broadcast forms a DTMC›

sublocale gossip_broadcast  MC_syntax proto_trans .

end

Theory MDP_RP_Certification

section ‹Certification of Reachability Problems on MDPs›

theory MDP_RP_Certification
imports
  "../MDP_Reachability_Problem"
  "HOL-Library.IArray"
  "HOL-Library.Code_Target_Numeral"
begin

context Reachability_Problem
begin

lemma p_ub':
  fixes x
  assumes 1: "s  S" "s D. s  S1  D  K s  (tS. pmf D t * x t)  x s"
  assumes 2: "s. s  S1  x s  0  (tS2. (s, t)  (SIGMA s:S1. DK s. set_pmf D)*)"
  assumes 3: "s. s  S - S1 - S2  x s = 0"
  assumes 4: "s. s  S2  x s = 1"
  shows "enn2real (p s)  x s"
proof (rule p_ub[OF 1 _ 4])
  fix s assume "s  S" "p s = 0" with 2[of s] p_pos[of s] p_S2[of s] 3[of s] show "x s = 0"
    by (cases "x s = 0") auto
qed

lemma n_lb':
  fixes x
  assumes "wf R"
  assumes 1: "s  S" "s D. s  S1  D  K s  x s  (tS. pmf D t * x t)"
  assumes 2: "s D. s  S1  D  K s  x s  0  tD. ((t, s)  R  t  S1  x t  0)  t  S2"
  assumes 3: "s. s  S - S1 - S2  x s = 0"
  assumes 4: "s. s  S2  x s = 1"
  shows "x s  enn2real (n s)"
proof (rule n_lb[OF 1 _ 4])
  fix s assume *: "s  S" "n s = 0"
  show "x s = 0"
  proof (rule ccontr)
    assume "x s  0"
    with * n_S2[of s] n_nS12[of s] 3[of s] have "s  S1"
      by (metis DiffI zero_neq_one)
    have "0 < n s"
      by (intro n_pos[of "λs. x s  0", OF x s  0 s  S1 ‹wf R])
         (metis zero_less_one n_S2 2)
    with ‹n s = 0 show False by auto
  qed
qed

end

no_notation Stream.snth (infixl "!!" 100) ― ‹we use @{text "!!"} for IArray›

subsection ‹Computable representation›

record mdp_reachability_problem =
  state_count :: nat
  distrs :: "(nat × rat) list list iarray"
  states1 :: "bool iarray"
  states2 :: "bool iarray"

record 'a RP_sub_cert =
  solution :: "rat iarray"
  witness :: "('a × nat) iarray"

record RP_cert =
  pos_cert :: "(nat × nat) RP_sub_cert"
  neg_cert :: "nat list RP_sub_cert"

definition "sparse_mult sx y = sum_list (map (λ(n, x). x * y !! n) sx)"

primrec lookup where
  "lookup d [] x = d"
| "lookup d (y#ys) x = (if fst y = x then snd y else lookup d ys x)"

lemma lookup_eq_map_of: "lookup d xs x = (case map_of xs x of Some x  x | None  d)"
  by (induct xs) simp_all

lemma lookup_in_set:
  "distinct (map fst xs)  x  set xs  lookup d xs (fst x) = snd x"
  unfolding lookup_eq_map_of by (subst map_of_is_SomeI[where y="snd x"]) simp_all

lemma lookup_not_in_set:
  "x  fst ` set xs  lookup d xs x = d"
  unfolding lookup_eq_map_of
  by (subst map_of_eq_None_iff[of xs x, THEN iffD2]) auto

lemma lookup_nonneg:
  "(x v. (x, v)  set xs  0  v)  (0::'a::ordered_comm_monoid_add)  lookup 0 xs x"
  apply (induction xs)
  apply simp
  apply force
  done

lemma sparse_mult_eq_sum_lookup:
  fixes xs :: "(nat × 'a::comm_semiring_1) list"
  assumes "list_all (λ(n, x). n < M) xs" "distinct (map fst xs)"
  shows "sparse_mult xs y = (i<M. lookup 0 xs i * y !! i)"
proof -
  from ‹distinct (map fst xs) have "distinct xs" "inj_on fst (set xs)"
    by (simp_all add: distinct_map)
  then have "sparse_mult xs y = (xset xs. snd x * y !! fst x)"
    by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
  also have " = (xset xs. lookup 0 xs (fst x) * y !! fst x)"
    by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
  also have " = (xfst ` set xs. lookup 0 xs x * y !! x)"
    using ‹inj_on fst (set xs) by (simp add: sum.reindex)
  also have " = (x<M. lookup 0 xs x * y !! x)"
    using assms(1)
    by (intro sum.mono_neutral_cong_left)
       (auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
  finally show ?thesis .
qed

lemma sum_list_eq_sum_lookup:
  fixes xs :: "(nat × 'a::comm_semiring_1) list"
  assumes "list_all (λ(n, x). n < M) xs" "distinct (map fst xs)"
  shows "sum_list (map snd xs) = (i<M. lookup 0 xs i)"
proof -
  from ‹distinct (map fst xs) have "distinct xs" "inj_on fst (set xs)"
    by (simp_all add: distinct_map)
  then have "sum_list (map snd xs) = (xset xs. snd x)"
    by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
  also have " = (xset xs. lookup 0 xs (fst x))"
    by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
  also have " = (xfst ` set xs. lookup 0 xs x)"
    using ‹inj_on fst (set xs) by (simp add: sum.reindex)
  also have " = (x<M. lookup 0 xs x)"
    using assms(1)
    by (intro sum.mono_neutral_cong_left)
       (auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
  finally show ?thesis .
qed

definition
  "valid_mdp_rp mdp 
    0 < state_count mdp 
    IArray.length (distrs mdp) = state_count mdp 
    IArray.length (states1 mdp) = state_count mdp 
    IArray.length (states2 mdp) = state_count mdp 
    (i<state_count mdp. ¬ (states1 mdp !! i  states2 mdp !! i) 
      list_all (λds. distinct (map fst ds)  list_all (λ(n, x). 0  x  n < state_count mdp) ds 
                     sum_list (map snd ds) = 1) (distrs mdp !! i) 
      ¬ List.null (distrs mdp !! i))"

definition
  "valid_sub_cert mdp c ord check 
    IArray.length (witness c) = state_count mdp 
    IArray.length (solution c) = state_count mdp 
    (i<state_count mdp.
      if states2 mdp !! i then solution c !! i = 1
      else if states1 mdp !! i then 0  solution c !! i 
        (list_all (λds. ord (sparse_mult ds (solution c)) (solution c !! i)) (distrs mdp !! i)) 
        (0 < solution c !! i  check (distrs mdp !! i) (witness c !! i))
      else solution c !! i = 0)"

definition
  "valid_pos_cert mdp c 
    valid_sub_cert mdp c (≤)
      (λD ((j, a), n). j < state_count mdp  snd (witness c !! j) < n  0 < solution c !! j 
        a < length D  lookup 0 (D ! a) j  0)"

definition
  "valid_neg_cert mdp c 
    valid_sub_cert mdp c (≥)
      (λD (J, n). list_all2 (λj d. j < state_count mdp  snd (witness c !! j) < n 
        lookup 0 d j  0  0 < solution c !! j) J D)"

definition
  "valid_cert mdp c  valid_pos_cert mdp (pos_cert c)  valid_neg_cert mdp (neg_cert c)"

lemma valid_mdp_rpD_length:
  assumes "valid_mdp_rp mdp"
  shows "0 < state_count mdp" "IArray.length (distrs mdp) = state_count mdp"
    "IArray.length (states1 mdp) = state_count mdp" "IArray.length (states2 mdp) = state_count mdp"
  using assms by (auto simp: valid_mdp_rp_def)

lemma valid_mdp_rpD:
  assumes "valid_mdp_rp mdp" "i < state_count mdp"
  shows "¬ (states1 mdp !! i  states2 mdp !! i)"
    and "ds n x. ds  set (distrs mdp !! i)  (n, x)  set ds  n < state_count mdp"
    and "ds n x. ds  set (distrs mdp !! i)  (n, x)  set ds  0  x"
    and "ds. ds  set (distrs mdp !! i)  sum_list (map snd ds) = 1"
    and "ds. ds  set (distrs mdp !! i)  distinct (map fst ds)"
    and "distrs mdp !! i  []"
  using assms by (auto simp: valid_mdp_rp_def list_all_iff List.null_def elim!: allE[of _ i])

lemma valid_mdp_rp_sparse_mult:
  assumes "valid_mdp_rp mdp" "i < state_count mdp" "ds  set (distrs mdp !! i)"
  shows "sparse_mult ds y = (i<state_count mdp. lookup 0 ds i * y !! i)"
  using valid_mdp_rpD(2,5)[OF assms] by (intro sparse_mult_eq_sum_lookup) (auto simp: list_all_iff)

lemma valid_sub_certD:
  assumes "valid_mdp_rp mdp" "valid_sub_cert mdp c ord check" "i < state_count mdp"
  shows "¬ states1 mdp !! i  ¬ states2 mdp !! i  solution c !! i = 0"
    and "states2 mdp !! i  solution c !! i = 1"
    and "states1 mdp !! i  0  solution c !! i"
    and "ds. states1 mdp !! i  ds  set (distrs mdp !! i)  ord (sparse_mult ds (solution c)) (solution c !! i)"
    and "ds. states1 mdp !! i  0 < solution c !! i  check (distrs mdp !! i) (witness c !! i)"
  using assms(2,3) valid_mdp_rpD(1)[OF assms(1,3)]
  by (auto simp add: valid_sub_cert_def list_all_iff)

lemma valid_pos_certD:
  assumes "valid_mdp_rp mdp" "valid_pos_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
    "0 < solution c !! i" "witness c !! i = ((j, a), n)"
  shows "snd (witness c !! j) < n  j < state_count mdp  a < length (distrs mdp !! i) 
          lookup 0 ((distrs mdp !! i) ! a) j  0  0 < solution c !! j"
  using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_pos_cert_def] assms(3,4)] assms(5-) by auto

lemma valid_neg_certD:
  assumes "valid_mdp_rp mdp" "valid_neg_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
    "0 < solution c !! i" "witness c !! i = (js, n)"
  shows "list_all2 (λj ds. j < state_count mdp  snd (witness c !! j) < n  lookup 0 ds j  0  0 < solution c !! j) js (distrs mdp !! i)"
  using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_neg_cert_def] assms(3)] assms(4-) by auto

context
  fixes mdp c
  assumes rp: "valid_mdp_rp mdp"
  assumes cert: "valid_cert mdp c"
begin

interpretation pmf_as_function .

abbreviation "S  {..< state_count mdp}"
abbreviation "S1  {i. i < state_count mdp  (states1 mdp) !! i}"
abbreviation "S2  {i. i < state_count mdp  (states2 mdp) !! i}"

lift_definition K :: "nat  nat pmf set" is
  "λi. if i < state_count mdp then
     { (λj. of_rat (lookup 0 D j) :: real) | D. D  set (distrs mdp !! i) }
     else { indicator {0} }"
proof (auto split: if_split_asm simp del: IArray.sub_def)
  fix n D assume n: "n < state_count mdp" and D: "D  set (distrs mdp !! n)"
  from valid_mdp_rpD(3)[OF rp this] show nn: "i. 0  lookup 0 D i"
    by (auto simp add: lookup_eq_map_of split: option.split dest: map_of_SomeD)
  show "(+ x. ennreal (real_of_rat (lookup 0 D x)) count_space UNIV) = 1"
    using valid_mdp_rpD(2,3,4,5)[OF rp n D]
    apply (subst nn_integral_count_space'[of "{..< state_count mdp}"])
    apply (auto intro: nn lookup_not_in_set simp: of_rat_sum[symmetric] lookup_nonneg)
    apply (subst sum_list_eq_sum_lookup[symmetric])
    apply (auto simp: list_all_iff lookup_eq_map_of split: option.split)
    done
next
  show "(+ x. ennreal (indicator {0} x) count_space UNIV) = 1"
    by (subst nn_integral_count_space'[of "{0}"]) auto
qed

interpretation MDP: Reachability_Problem K S S1 S2
proof
  show "S1  S2 = {}" "S1  S" "S2  S"
    using valid_mdp_rpD(1)[OF rp] by auto
  show "finite S" "S  {}"
    using ‹valid_mdp_rp mdp by (auto simp add: valid_mdp_rp_def)
  show "s. K s  {}"
    using valid_mdp_rpD(6)[OF rp] by transfer simp
  show "s. finite (K s)"
    by transfer simp

  fix s assume "s  S" then show "(DK s. set_pmf D)  S"
    using valid_mdp_rpD(2)[OF rp]
    by transfer (auto simp: lookup_eq_map_of split: option.splits dest!: map_of_SomeD)
qed

definition "P_max s = enn2real (MDP.p s)"
definition "P_min s = enn2real (MDP.n s)"

lemma
  assumes "i < state_count mdp"
  shows P_max: "P_max i  real_of_rat (solution (pos_cert c) !! i)" (is ?max)
    and P_min: "P_min i  real_of_rat (solution (neg_cert c) !! i)" (is ?min)
proof -
  have "valid_pos_cert mdp (pos_cert c)" "valid_neg_cert mdp (neg_cert c)"
    using ‹valid_cert mdp c by (auto simp: valid_cert_def)
  note pos = this(1)[unfolded valid_pos_cert_def] and neg = this(2)[unfolded valid_neg_cert_def]

  let ?x = "λs. real_of_rat (solution (pos_cert c) !! s)"
  have "enn2real (MDP.p i)  ?x i"
  proof (rule MDP.p_ub')
    show "i  S" using assms by simp
  next
    fix s D assume "s  S1" "D  K s"
    then obtain j where j: "j < length (distrs mdp !! s)"
      "i. i < state_count mdp  pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
      by transfer (auto simp: in_set_conv_nth)
    with valid_sub_certD(4)[OF ‹valid_mdp_rp mdp pos, of s "distrs mdp !! s ! j"] s  S1›
         valid_mdp_rp_sparse_mult[OF ‹valid_mdp_rp mdp, of s "distrs mdp !! s ! j" "solution (pos_cert c)"]
    show "(tS. pmf D t * ?x t)  ?x s"
      by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
  next
    fix s a assume "s  S2" then show "?x s = 1"
      using valid_sub_certD[OF ‹valid_mdp_rp mdp pos] by simp
  next
    fix s define X where "X = (SIGMA s:S1. DK s. set_pmf D)"
    assume "s  S1" "?x s  0"
    with valid_sub_certD(3)[OF rp pos, of s]
    have "0 < ?x s"
      by simp
    with sS1› show "tS2. (s, t)  X*"
    proof (induction n"snd (witness (pos_cert c) !! s)" arbitrary: s rule: less_induct)
      case (less s)
      obtain t a n where eq: "witness (pos_cert c) !! s = ((t, a), n)"
        by (metis prod.exhaust)
      from valid_pos_certD[OF rp ‹valid_pos_cert mdp (pos_cert c) _ _ _ this] less.prems
      have ord: "snd (witness (pos_cert c) !! t) < snd (witness (pos_cert c) !! s)"
        and t: "lookup 0 (distrs mdp !! s ! a) t  0" "0 < ?x t" "tS" "a < length (distrs mdp !! s)"
        unfolding eq by auto
      with sS1› have X: "(s, t)  X"
        unfolding X_def
        by (transfer fixing: s t a c)
           (auto simp: X_def in_set_conv_nth
                 intro!: exI[of _ "λj. real_of_rat (lookup 0 (distrs mdp !! s ! a) j)"]
                         exI[of _ "distrs mdp !! s ! a"] exI[of _ a])
      show ?case
      proof cases
        assume "t  S1"
        with less.hyps[OF ord _ 0 < ?x t] X show ?thesis
          by auto
      next
        assume "t  S1"
        with valid_sub_certD[OF ‹valid_mdp_rp mdp pos, of t] 0 < ?x t tS›
        have "t  S2"
          by auto
        with X show ?thesis
          by auto
      qed
    qed
  next
    fix s assume "s  S - S1 - S2" then show "?x s = 0"
      using valid_sub_certD(1)[OF ‹valid_mdp_rp mdp pos, of s] by simp
  qed
  then show ?max
    by (simp add: P_max_def)

  let ?x = "λs. real_of_rat (solution (neg_cert c) !! s)"
  have "?x i  enn2real (MDP.n i)"
  proof (rule MDP.n_lb')
    show "i  S" using assms by simp
  next
    fix s D assume "s  S1" "D  K s"
    then obtain j where j: "j < length (distrs mdp !! s)"
      "i. i < state_count mdp  pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
      by transfer (auto simp: in_set_conv_nth)
    with valid_sub_certD(4)[OF ‹valid_mdp_rp mdp neg, of s "distrs mdp !! s ! j"] s  S1›
         valid_mdp_rp_sparse_mult[OF ‹valid_mdp_rp mdp, of s "distrs mdp !! s ! j" "solution (neg_cert c)"]
    show "?x s  (tS. pmf D t * ?x t)"
      by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
  next
    fix s a assume "s  S2" then show "?x s = 1"
      using valid_sub_certD[OF ‹valid_mdp_rp mdp neg] by simp
  next
    show "wf ((S × S  {(s, t). snd (witness (neg_cert c) !! t) < snd (witness (neg_cert c) !! s)})¯)" (is "wf ?F")
      using MDP.S_finite
      by (intro finite_acyclic_wf_converse acyclicI_order[where f="λs. snd (witness (neg_cert c) !! s)"]) auto

    fix s D assume 2: "s  S1" "D  K s" and "?x s  0"
    then have "0 < ?x s"
      using valid_sub_certD(3)[OF ‹valid_mdp_rp mdp neg, of s] by auto

    from 2 obtain a where a: "a < length (distrs mdp !! s)"
      "i. i < state_count mdp  pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! a) i)"
      by transfer (auto simp: in_set_conv_nth)

    obtain js n where eq: "witness (neg_cert c) !! s = (js, n)"
      by (metis prod.exhaust)
    from valid_neg_certD[OF ‹valid_mdp_rp mdp ‹valid_neg_cert mdp (neg_cert c) _ _ _ eq] a s  S1› 0 < ?x s
    have *: "length js = length (distrs mdp !! s)" "js ! a  S"
      "snd (witness (neg_cert c) !! (js ! a)) < snd (witness (neg_cert c) !! s)"
      "lookup 0 (distrs mdp !! s ! a) (js ! a)  0"
      "0 < ?x (js ! a)"
      unfolding eq by (auto dest: list_all2_nthD2 list_all2_lengthD)
    with a s  S1› have js_a: "js ! a  D" "(js ! a, s)  ?F"
      by (auto simp: set_pmf_iff)

    show "tD. (t, s)  ?F  t  S1  ?x t  0  t  S2"
    proof cases
      assume "js ! a  S1" with js_a 0 < ?x (js ! a) show ?thesis by auto
    next
      assume "js ! a  S1"
      with 0 < ?x (js ! a) js!a  S› valid_sub_certD[OF rp neg, of "js ! a"]
      have "js ! a  S2"
        by (auto simp:  less_le)
      with js ! a  D show ?thesis
        by auto
    qed
  next
    fix s assume "s  S - S1 - S2" then show "?x s = 0"
      using valid_sub_certD(1)[OF ‹valid_mdp_rp mdp neg, of s] by simp
  qed
  then show ?min
    by (simp add: P_min_def)
qed

end

end

Theory MDP_RP

section ‹Value Iteration for Reachability Probabilities of MDPs›

theory MDP_RP
  imports "../Markov_Models"
begin

subsection ‹Auxiliary Theorems›

lemma INF_Union_eq: "(INF xA. f x) = (INF aA. INF xa. f x)" for f :: "_  'a::complete_lattice"
  by (auto intro!: antisym INF_greatest intro: INF_lower2)

lemma lift_option_eq_None: "lift_option f A B = None  (A  None  B = None)"
  by (cases A; cases B; auto)

lemma lift_option_eq_Some: "lift_option f A B = Some y  (a b. A = Some a  B = Some b  y = f a b)"
  by (cases A; cases B; auto)

lemma ord_option_Some1_iff: "ord_option R (Some a) y  (b. y = Some b  R a b)"
  by (cases y; auto)

lemma ord_option_Some2_iff: "ord_option R x (Some b)  (a. x = Some a  R a b)"
  by (cases x; auto)

lemma sym_Restr: "sym A  sym (Restr A S)"
  by (auto simp: sym_def)

lemma trans_Restr: "trans A  trans (Restr A S)"
  by (auto simp: trans_def)

lemma image_eq_singleton_iff: "inj_on f S  f ` S = {y}  (x. S = {x}  y = f x)"
  by (auto elim: inj_img_insertE)

lemma quotient_eq_singleton: "equiv A r  A // r = {B}  B = A"
  using Union_quotient[of A r] by auto

lemma UN_singleton_image: "(xA. {f x}) = f ` A"
  by auto

lemma image_eq_singeltonD: "f ` A = {x}  aA. f a = x"
  by auto

lemma fun_ord_refl: "reflp ord   reflp (fun_ord ord)"
  by (auto simp: fun_ord_def reflp_def)

lemma fun_ord_trans: "transp ord   transp (fun_ord ord)"
  by (fastforce simp: fun_ord_def transp_def)

lemma fun_ord_antisym: "antisymp ord   antisymp (fun_ord ord)"
  by (fastforce simp: fun_ord_def antisymp_def)

lemma fun_ord_combine:
  "fun_ord ord a b  fun_ord ord c d  (s. ord (a s) (b s)  ord (c s) (d s)  ord (e s) (f s))  fun_ord ord e f"
  by (auto simp: fun_ord_def)

lemma not_all_eq: "~ (y. x  y)"
  by auto

lemma ball_vimage_iff: "(xf -` X. P x)  (x. f x  X  P x)"
  by auto

lemma UN_If_cases: "(xX. if P x then A x else B x) = (x{xX. P x}. A x)  (x{xX. ¬ P x}. B x)"
  by (auto split: if_splits)

lemma (in Reachability_Problem) n_eq_0_closed:
  assumes s: "s  S'" and S': "S'  S" "S'  S2 = {}" and closed: "s. s  S'  DK s. D  S'"
  shows "n s = 0"
proof -
  from closed obtain ct where ct: "s. s  S'  ct s  K s" "s. s  S'  ct s  S'"
    by metis

  define cfg where "cfg = memoryless_on (λs. if s  S' then ct s else arb_act s)"

  have cfg_on: "cfg s  cfg_on s" for s
    unfolding cfg_def using ct by (intro memoryless_on_cfg_onI) auto

  have state_cfg[simp]: "state (cfg s) = s" for s
    unfolding cfg_def by (intro state_memoryless_on)
  have action_cfg[simp]: "action (cfg s) = (if s  S' then ct s else arb_act s)" for s
    unfolding cfg_def by (intro action_memoryless_on)
  have cont_cfg[simp]: "s  S'  t  ct s  cont (cfg s) t = cfg t" for s t
    unfolding cfg_def by (intro cont_memoryless_on) auto

  from s have "v (cfg s) = 0"
  proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
    case (valid cfg') with cfg_on s S' show ?case
      by (auto simp: valid_cfg_def)
  next
    case (nS2 cfg') with S' show ?case
      by auto
  next
    case (cont cfg') with S' ct show ?case
      by (force simp: set_K_cfg)
  qed
  show "n s = 0"
  proof (rule n_eq_0)
    show "s  S" using s S' by auto
  qed fact+
qed

lemma (in Reachability_Problem) n_lb_ennreal:
  fixes x
  assumes "s  S"
  assumes solution: "s D. s  S1  D  K s  x s  (tS. ennreal (pmf D t) * x t)"
  assumes solution_n0: "s. s  S  n s = 0  x s = 0"
  assumes solution_S2: "s. s  S2  x s = 1"
    and le_1:  "s. s  S  x s  1"
  shows "x s  n s" (is "_  ?y s")
proof -
  have x_less_top[simp]: "s  S  x s < top" for s
    using le_1[of s] by (auto simp: less_top[symmetric] top_unique)

  have "enn2real (x s)  enn2real (n s)"
    apply (rule n_lb[OF sS])
    subgoal for s D
      by (rule ennreal_le_iff[THEN iffD1])
          (use S1 in auto intro!: sum_nonneg simp add: subset_eq solution sum_ennreal[symmetric] ennreal_mult simp del: sum_ennreal›)
    apply (auto simp: solution_n0 solution_S2)
    done
  with sS show ?thesis
    by (subst (asm) ennreal_le_iff[symmetric]) (simp_all add: real_n)
qed

lifting_forget pmf_as_function.pmf.lifting

text ‹
  Type to describe MDP components. The support (i.e. elements which are not mapped to an empty
set) is the set of states of the component.

Most of this is from:
  Formal verification of probabilistic systems
  Luca de Alfaro (PhD thesis, 1997)
and
  Reachability in MDPs: Refining Convergence of Value Iteration
  Serge Haddad and Benjamin Monmege (2014)
›

typedef 's mdpc = "UNIV :: ('s  's pmf set) set"
  by auto

setup_lifting type_definition_mdpc

lift_definition states :: "'s mdpc  's set"
  is dom .

declare [[coercion states]]

lift_definition actions :: "'s mdpc  's  's pmf set"
  is "λf s. case f s of None  {} | Some a  a" .

lemma in_states: "actions φ s  {}  s  states φ"
  by transfer auto

lemma mdpc_eqI: "states φ = states ψ  (s. s  states φ  actions φ s = actions ψ s)  φ = ψ"
  apply transfer
  apply (rule ext)
  subgoal premises prems for φ ψ x
    using prems(1) prems(2)[of x]
    by (cases "x  dom φ") (auto simp: fun_eq_iff split: option.splits)
  done

lift_definition map_mdpc :: "('s  't)  's mdpc  't mdpc"
  is "λm f s. if f ` (m -` {s})  {None} then None else Some {map_pmf m d | d A t. m t = s  f t = Some A  d  A}" .

lemma states_map_mdpc: "states (map_mdpc f M) = f ` (states M)"
  by (transfer fixing: f) (auto simp: subset_eq image_iff dom_def split: if_splits)

lemma actions_map_mdpc_eq_Collect: "actions (map_mdpc f M) s = {map_pmf f d | d t. f t = s  d  actions M t}"
  by transfer (force simp: subset_eq split: option.splits)

lemma actions_map_mdpc: "actions (map_mdpc f M) s = map_pmf f ` (tf -` {s}. actions M t)"
  by (auto simp: actions_map_mdpc_eq_Collect)

lemma map_mdpc_compose: "map_mdpc f (map_mdpc g M) = map_mdpc (f  g) M"
  by (intro mdpc_eqI)
     (auto simp add: states_map_mdpc image_comp actions_map_mdpc image_UN map_pmf_compose[symmetric]
                     vimage_comp[symmetric])

lemma map_mdpc_id: "map_mdpc id = id"
  by (auto simp: fun_eq_iff states_map_mdpc actions_map_mdpc intro!: mdpc_eqI)

lemma finite_states_map: "finite (states M)  finite (map_mdpc f M)"
  by (simp add: states_map_mdpc)

lemma finite_actions_map:
  assumes "finite (states M)" "s. finite (actions M s)" shows "finite (actions (map_mdpc f M) s)"
proof -
  have "(xf -` {s}. actions M x) = (xf -` {s}  states M. actions M x)"
    using in_states[of M] by auto
  with assms show ?thesis
    by (auto simp add: actions_map_mdpc)
qed

lift_definition fix_loop :: "'s  's mdpc  's mdpc"
  is "λs M t. if s = t then Some {return_pmf s} else M t" .

lemma states_fix_loop[simp]: "states (fix_loop s M) = insert s (states M)"
  by transfer (auto simp: subset_eq image_iff dom_def split: if_splits)

lemma actions_fix_loop[simp]: "actions (fix_loop s M) t = (if s = t then {return_pmf s} else actions M t)"
  by transfer auto

lemma fix_loop_idem: "fix_loop s (fix_loop s M) = fix_loop s M"
  by (auto intro!: mdpc_eqI)

lemma fix_loop_commute: "fix_loop s (fix_loop t M) = fix_loop t (fix_loop s M)"
  by (auto intro!: mdpc_eqI)

lemma map_fix_loop:
  assumes f_s: "t. f s = f t  t = s"
  shows "map_mdpc f (fix_loop s M) = fix_loop (f s) (map_mdpc f M)"
  by (auto simp: states_map_mdpc actions_map_mdpc_eq_Collect split: if_splits intro!: mdpc_eqI dest!: f_s f_s[OF sym]) force+

lift_definition map_actions :: "('s  's pmf set  's pmf set)  's mdpc  's mdpc"
  is "λm f s. map_option (m s) (f s)" .

lemma state_map_actions[simp]: "states (map_actions f φ) = states φ"
  by transfer auto

lemma actions_map_actions[simp]: "(s  states φ  f s {} = {})  actions (map_actions f φ) s = f s (actions φ s)"
  by transfer (auto split: option.splits)

lift_definition restrict_states :: "'s set  's mdpc  's mdpc"
  is "λS f s. if s  S then f s else None" .

lemma state_restrict_states[simp]: "states (restrict_states S φ) = states φ  S"
  by transfer (auto split: if_splits)

lemma actions_restrict_states[simp]: "actions (restrict_states S φ) s = (if s  S then actions φ s else {})"
  by transfer (auto split: if_splits)

lemma restrict_states_idem: "states φ  A  restrict_states A φ = φ"
  by transfer (force simp: fun_eq_iff subset_eq dom_def)

instantiation mdpc :: (type) lattice
begin

lift_definition less_eq_mdpc :: "'s mdpc  's mdpc  bool"
  is "fun_ord (ord_option (⊆))" .

definition less_mdpc :: "'s mdpc  's mdpc  bool"
  where "less_mdpc f g  (f  g  ¬ g  f)"

lift_definition inf_mdpc :: "'s mdpc  's mdpc  's mdpc"
  is "λf g s. lift_option (∩) (f s) (g s)" .

lift_definition sup_mdpc :: "'s mdpc  's mdpc  's mdpc"
  is "λf g s. combine_options (∪) (f s) (g s)" .

instance
proof
  fix x y z :: "'s mdpc"
  show "(x < y) = (x  y  ¬ y  x)"
    by (rule less_mdpc_def)
  note ord =
    fun_ord_refl[where 'b="'s", OF reflp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
    fun_ord_trans[where 'b="'s", OF transp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
    fun_ord_antisym[where 'b="'s", OF antisymp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
  show  "x  x" "x  y  y  z  x  z" "x  y  y  x  x = y"
    by (transfer; insert ord; auto simp: transp_def antisymp_def reflp_def)+
  show "x  y  x" "x  y  y"
    by (transfer; auto simp: fun_ord_def ord_option.simps lift_option_def split: Option.bind_split)+
  show "x  y  x  z  x  y  z"
    apply transfer
    subgoal premises prems for a b c
      using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
    done
  show "x  x  y" "y  x  y"
    by (transfer; auto simp: fun_ord_def ord_option.simps combine_options_def not_all_eq split: option.splits)+
  show "y  x  z  x  y  z  x"
    apply transfer
    subgoal premises prems for a b c
      using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
    done
qed
end

instantiation mdpc :: (type) complete_lattice
begin

lift_definition bot_mdpc :: "'a mdpc" is "λ_. None" .

lift_definition top_mdpc :: "'a mdpc" is "λ_. Some UNIV" .

lift_definition Sup_mdpc :: "'a mdpc set  'a mdpc"
  is "λM s. if mM. m s  None then Some ({ d | m d. m  M  m s = Some d}) else None" .

lift_definition Inf_mdpc :: "'a mdpc set  'a mdpc"
  is "λM s. if mM. m s = None then None else Some ({ d | m d. m  M  m s = Some d})" .

instance
proof
  fix x :: "'a mdpc" and X :: "'a mdpc set"
  show "x  X  X  x" "x  X  x  X"
    by (transfer; force simp: fun_ord_def ord_option_Some1_iff ord_option_Some2_iff)+
  show "(y. y  X  x  y)  x  X"
    apply transfer
    apply (clarsimp simp: fun_ord_def ord_option.simps)
    subgoal premises P for X m x
      using P[rule_format, of _ x]
      by (cases "m x") fastforce+
    done
  show "(y. y  X  y  x)  X  x"
    apply transfer
    apply (clarsimp simp: fun_ord_def ord_option.simps)
    subgoal premises P for X m x y z
      using P(1)[rule_format, of _ x] P(1)[rule_format, of y x] P(2,3)
      by auto force
    done
qed (transfer; auto)+
end

lemma states_sup[simp]: "states (φ  ψ) = states φ  states ψ"
  by transfer (auto simp: combine_options_def split: option.splits)

lemma states_SUP[simp]: "states (A) = (aA. states a)"
  by transfer (auto simp: dom_def split: option.splits if_splits)

lemma states_inf[simp]: "states (φ  ψ) = states φ  states ψ"
  by transfer (auto simp: lift_option_eq_Some split: option.splits)

lemma states_mono: "φ  ψ  states φ  states ψ"
  using states_sup[of φ ψ] by (auto simp del: states_sup simp add: sup_absorb2)

lemma actions_sup[simp]: "actions (φ  ψ) = actions φ  actions ψ"
  by transfer (auto simp: combine_options_def split: option.splits)

lemma actions_SUP[simp]: "actions (A) s = (aA. actions a s)"
  by transfer (auto simp: dom_def split: option.splits if_splits, blast)

lemma actions_inf[simp]: "actions (φ  ψ) = actions φ  actions ψ"
  by transfer (auto simp: fun_eq_iff split: option.splits)

lemma actions_mono: assumes *: "φ  ψ" shows "actions φ  actions ψ"
proof -
  have "actions φ  actions φ  actions ψ"
    by auto
  also have " = actions ψ"
    using * actions_sup[of φ ψ] by (auto simp add: sup_absorb2)
  finally show ?thesis .
qed

lemma le_mdpcI: "states M  states N  (s. s  states M  actions M s  actions N s)  M  N"
  by transfer
     (force simp: fun_ord_def ord_option.simps subset_eq split: option.splits)

lemma le_mdpc_iff: "M  N  states M  states N  (s. actions M s  actions N s)"
  using states_mono[of M N] actions_mono[of M N] by (auto simp: le_fun_def intro!: le_mdpcI)

lemma map_actions_le: "(s A. s  states φ  f s A  A)  map_actions f φ  φ"
  apply (intro le_mdpcI)
  subgoal by auto
  subgoal premises p for s using p(1)[of s] p(1)[of s "{}"] p(2) actions_map_actions by auto
  done

lemma restrict_states_mono: "A  B  φ  ψ  restrict_states A φ  restrict_states B ψ"
  using states_mono[of φ ψ] actions_mono[of φ ψ] by (intro le_mdpcI) (auto simp: le_fun_def)

lemma restrict_states_le: "restrict_states A M  M"
  by (intro le_mdpcI) auto

lemma eq_bot_iff_states: "φ = bot  states φ = {}"
  by transfer auto

lemma fix_loop_neq_bot: "fix_loop s N  bot"
  unfolding eq_bot_iff_states by simp

lemma
  shows states_bot[simp]: "states bot = {}"
    and actions_bot[simp]: "actions bot = (λs. {})"
  unfolding fun_eq_iff by (transfer; auto)+

lemma inf_eq_bot_eq_disjnt_states: "A  B = bot  disjnt (states A) (states B)"
  unfolding disjnt_def by transfer  (auto simp: fun_eq_iff lift_option_eq_None)

text ‹Enabled States›
definition en :: "'s mdpc  's rel"
  where "en φ = {(s, t) | d s t. d  actions φ s  t  set_pmf d}"

lemma en_sup[simp]: "en (φ  ψ) = en φ  en ψ"
  by (auto simp: en_def)

lemma en_SUP[simp]: "en (Sup A) = (aA. en a)"
  by (auto simp: en_def)

lemma en_mono: "φ  ψ  en φ  en ψ"
  unfolding en_def
  apply transfer
  apply (auto simp: fun_ord_def split: option.splits)
  apply (auto simp add: ord_option.simps subset_iff)
  apply force
  done

lemma en_states: "(s, t)  en M  s  states M"
  using in_states[of M s] by (auto simp: en_def)

lemma en_bot[simp]: "en bot = {}"
  by (simp add: en_def)

lemma en_fix_loop[simp]: "en (fix_loop s M) = insert (s, s) (en M - {s} × UNIV)"
  by (force simp add: en_def )

lift_definition trivial :: "'s  's mdpc" is "λs. (λ_. None)(s := Some {})" .

lemma states_trivial[simp]: "states (trivial s) = {s}"
  by transfer auto

lemma actions_trivial[simp]: "actions (trivial s) = (λ_. {})"
  by transfer (auto simp: fun_eq_iff)

lemma en_trivial[simp]: "en (trivial s) = {}"
  by (simp add: en_def)

lemma trivial_le_iff: "trivial x  φ  x  states φ"
  by transfer (auto simp: ord_option.simps fun_ord_def)

lemma trivial_le: "x  states φ  trivial x  φ"
  unfolding trivial_le_iff .

lemma trivial_neq_bot: "trivial x  bot"
  by transfer auto

lift_definition loop :: "'s  's mdpc"
  is "λs. (λ_. None)(s := Some {return_pmf s})" .

lemma states_loop[simp]: "states (loop s) = {s}"
  by transfer auto

lemma actions_loop: "actions (loop s) = ((λ_. {})(s := {return_pmf s}))"
  by transfer (auto simp: fun_eq_iff)

lemma
  shows actions_loop_self[simp]: "actions (loop s) s = {return_pmf s}"
    and actions_loop_neq[simp]: "s  t  actions (loop s) t = {}"
  by (simp_all add: actions_loop)

lemma en_loop[simp]: "en (loop s) = {(s, s)}"
  by (auto simp: en_def actions_loop)

lemma loop_neq_bot: "loop s  bot"
  unfolding eq_bot_iff_states by simp

lemma loop_le: "loop x  M  (x  states M  return_pmf x  actions M x)"
  by (auto simp: le_mdpc_iff actions_loop)

lemma le_loop: "M  loop x  (states M  {x}  actions M x  {return_pmf x})"
  using in_states[of M] by (auto simp: le_mdpc_iff actions_loop)

text ‹Strongly Connected (SC)›
definition sc :: "'s mdpc  bool"
  where "sc φ  states φ × states φ  (en φ)*"

lemma scD: "sc φ  x  states φ  y  states φ  (x, y)  (en φ)*"
  by (auto simp: sc_def)

lemma scI: "(x y. x  states φ  y  states φ  (x, y)  (en φ)*)  sc φ"
  by (auto simp: sc_def)

lemma sc_trivial[simp]: "sc (trivial s)"
  by (simp add: sc_def)

lemma sc_loop[simp]: "sc (loop s)"
  by (auto simp: sc_def)

lemma sc_bot[simp]: "sc bot"
  by (simp add: sc_def)

lemma sc_SupI_directed:
  assumes A: "a. a  A  sc a"
    and directed: "a b. a  A  b  A  cA. a  c  b  c"
  shows "sc (Sup A)"
  unfolding sc_def
proof clarsimp
  fix x y a b assume "a  A" "b  A" and xy: "x  states a" "y  states b"
  with directed obtain c where "c  A" "a  c" "b  c"
    by auto
  with xy have "x  states c" "y  states c"
    using states_mono[of a c] states_mono[of b c] by auto
  with A[OF c  A] c  A
  have "(x, y)  (en c)*"
    by (auto simp: sc_def subset_eq)
  then show "(x, y)  (xA. en x)*"
    using rtrancl_mono[of "en c" "aA. en a"] cA by auto
qed

lemma sc_supI:
  assumes φ: "sc φ" and ψ: "sc ψ" and not_disjoint: "φ  ψ  bot"
  shows "sc (φ  ψ)"
  unfolding sc_def
proof safe
  fix x y assume "x  states (φ  ψ)" "y  states (φ  ψ)"
  moreover obtain z where "z  states φ" "z  states ψ"
    using not_disjoint by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)
  moreover have "(en φ)*  (en ψ)*  (en (φ  ψ))*"
    by (metis rtrancl_Un_subset en_sup)
  ultimately have "(x, z)  (en (φ  ψ))*" "(z, y)  (en (φ  ψ))*"
    using φ ψ by (auto dest: scD)
  then show "(x, y)  (en (φ  ψ))*"
    by auto
qed

lemma sc_eq_loop:
  assumes M: "sc M" and s: "s  M" "actions M s = {return_pmf s}" shows "M = loop s"
proof -
  { fix t assume "t  M"
    then have "(s, t)  (en M)*"
      using M[THEN scD, OF s  M t  M] by simp
    from this have "t = s"
      by (induction rule: rtrancl_induct) (auto simp: en_def ‹actions M s = {return_pmf s}) }
  then have "states M = {s}"
    using s  M by blast
  then show ?thesis
    by (intro mdpc_eqI) (auto simp: ‹actions M s = {return_pmf s})
qed

lemma sc_eq_trivial:
  assumes M: "sc M" and s: "s  M" "actions M s = {}" shows "M = trivial s"
proof -
  { fix t assume "t  M" "t  s"
    then have "(s, t)  (en M)+"
      using M[THEN scD, OF s  M t  M] by (simp add: rtrancl_eq_or_trancl)
    from tranclD[OF this] ‹actions M s = {} have False
      by (auto simp: en_def) }
  then have "states M = {s}"
    using s  M by auto
  then show ?thesis
    by (intro mdpc_eqI) (auto simp: ‹actions M s = {})
qed

definition closed_mdpc :: "'s mdpc  bool"
  where "closed_mdpc φ  en φ  states φ × states φ"

lemma closed_mdpcD: "closed_mdpc φ  D  actions φ x  y  D  y  states φ"
  by (auto simp: closed_mdpc_def en_def)

lemma closed_mdpc_supI: "closed_mdpc φ  closed_mdpc ψ  closed_mdpc (φ  ψ)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_SupI: "(a. a  A  closed_mdpc a)  closed_mdpc (A)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_infI: "closed_mdpc φ  closed_mdpc ψ  closed_mdpc (φ  ψ)"
  using en_mono[of "φ  ψ" φ] en_mono[of "φ  ψ" ψ]
  by (auto simp: closed_mdpc_def lift_option_eq_Some)

lemma closed_mdpc_trivial[simp]: "closed_mdpc (trivial s)"
  by (simp add: closed_mdpc_def)

lemma closed_mdpc_bot[simp]: "closed_mdpc bot"
  by (simp add: closed_mdpc_def)

lemma closed_mdpc_loop[simp]: "closed_mdpc (loop s)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_fix_loop: "closed_mdpc M  closed_mdpc (fix_loop s M)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_map: assumes M: "closed_mdpc M" shows "closed_mdpc (map_mdpc f M)"
  using closed_mdpcD[OF M]
  by (auto simp: closed_mdpc_def en_def actions_map_mdpc states_map_mdpc intro!: imageI intro: in_states)

definition close :: "'s mdpc  's mdpc"
  where "close φ = map_actions (λs A. {aA. set_pmf a  states φ}) φ"

lemma
  shows states_close[simp]: "states (close φ) = states φ"
    and actions_close[simp]: "actions (close φ) s = {aactions φ s. a  states φ}"
  by (auto simp: close_def)

lemma closed_close: "closed_mdpc (close φ)"
  by (auto simp add: closed_mdpc_def en_def intro: in_states)

lemma close_closed: "closed_mdpc φ  close φ = φ"
  unfolding closed_mdpc_def by (intro mdpc_eqI) (auto simp: en_def)

lemma close_close: "close (close φ) = close φ"
  by (simp add: closed_close close_closed)

lemma close_le: "close M  M"
  unfolding close_def by (intro map_actions_le) auto

lemma close_mono: "φ  ψ  close φ  close ψ"
  using states_mono[of φ ψ] actions_mono[of φ ψ]
  unfolding close_def by (intro le_mdpcI) (auto simp: le_fun_def)

text ‹End Component (EC)›
definition ec :: "'s mdpc  bool"
  where "ec φ  sc φ  closed_mdpc φ"

lemma ec_trivial[simp]: "ec (trivial s)"
  by (auto simp: ec_def)

lemma ec_bot[simp]: "ec bot"
  by (auto simp: ec_def)

lemma ec_loop[simp]: "ec (loop s)"
  by (auto simp: ec_def)

lemma ec_sup: "ec φ  ec ψ  φ  ψ  bot  ec (φ  ψ)"
  by (simp add: ec_def sc_supI closed_mdpc_supI)

lemma ec_Sup_directed:
  "(a. a  A  ec a)  (a b. a  A  b  A  cA. a  c  b  c)  ec (A)"
  by (auto simp: ec_def closed_mdpc_SupI sc_SupI_directed)

text ‹Maximal End Component (MEC) relative to @{term M}
definition mec :: "'s mdpc  's mdpc  bool"
  where "mec M φ  ec φ  φ  M  (ψM. ec ψ  φ  ψ  φ = ψ)"

lemma mec_refl: "ec M  mec M M"
  by (auto simp: mec_def)

lemma mec_le: "mec M φ  φ  M"
  by (auto simp: mec_def)

lemma mec_ec: "mec M φ  ec φ"
  by (auto simp: mec_def)

lemma mec_least: "mec M φ  ψ  M  φ  ψ  ec ψ  φ  ψ"
  by (auto simp: mec_def)

lemma mec_bot_imp_bot: assumes "mec φ bot" shows "φ = bot"
proof (rule ccontr)
  assume "φ  bot"
  then obtain x where "x  states φ"
    unfolding eq_bot_iff_states by auto
  then have "ec (trivial x)" "trivial x  φ"
    by (auto intro: trivial_le)
  then have "trivial x = bot"
    using ‹mec φ bot› by (auto simp: mec_def)
  then show False
    by (simp add: trivial_neq_bot)
qed

lemma mec_imp_bot_eq_bot: "mec φ ψ  φ = bot  ψ = bot"
  using mec_bot_imp_bot[of φ] by (auto simp: mec_def)

lemma mec_unique: assumes φ: "mec M φ" and ψ: "mec M ψ" and "φ  ψ  bot" shows "φ = ψ"
proof -
  have "mec M (φ  ψ)"
    using assms
    by (auto intro!: mec_def[THEN iffD2] ec_sup antisym dest: mec_ec mec_le)
       (blast intro: le_supI1 mec_least[of M])
  with mec_least[OF φ, of "φ  ψ"] mec_least[OF ψ,  of "φ  ψ"] mec_le[OF this] mec_ec[OF this]
  show "φ = ψ"
    by auto
qed

lemma mec_exists: assumes φ: "φ  bot" "ec φ" and M: "φ  M" shows "ψφ. mec M ψ"
proof (intro exI conjI)
  show "φ  {ψ. φ  ψ  ψ  M  ec ψ}"
    using φ M by (intro Sup_upper) auto
  show "mec M ({ψ. φ  ψ  ψ  M  ec ψ})"
    unfolding mec_def
  proof safe
    show "ec ({ψ. φ  ψ  ψ  M  ec ψ})"
    proof (safe intro!: ec_Sup_directed)
      fix a b assume *: "φ  a" "φ  b" and "a  M" "b  M" "ec a" "ec b"
      moreover have "a  b  bot"
        using * φ bot_unique[of "φ"] le_inf_iff[of φ a b] by (auto simp del: inf.bounded_iff)
      ultimately show "c{ψ. φ  ψ  ψ  M  ec ψ}. a  c  b  c"
        by (intro bexI[of _ "sup a b"]) (auto intro: le_supI1 intro!: ec_sup)
    qed
    fix ψ assume ψ: "ψ  M" "ec ψ" "{ψ. φ  ψ  ψ  M  ec ψ}  ψ"
    have "φ  {ψ. φ  ψ  ψ  M  ec ψ}"
      using assms by (auto intro!: Sup_upper)
    also have "  ψ" by fact
    finally show "{ψ. φ  ψ  ψ  M  ec ψ} = ψ"
      using ψ by (intro antisym Sup_upper) auto
  qed (auto intro!: Sup_least)
qed

lemma mec_exists': "x  states M  ψ. x  states ψ  mec M ψ"
  using mec_exists[of "trivial x"] by (auto simp: trivial_neq_bot trivial_le_iff)

lemma mec_loop: "x  states M  actions M x = {return_pmf x}  mec M (loop x)"
  apply (auto simp: mec_def loop_le ec_def)
  subgoal for φ
    using sc_eq_loop[of φ x] actions_mono[of φ M, THEN le_funD, of x] by auto
  done

lemma mec_fix_loop: "mec (fix_loop s M) (loop s)"
  by (intro mec_loop) auto

definition trivials :: "'s mdpc  's set"
  where "trivials M = {x. mec M (trivial x)}"

lemma trivials_subset_states: "trivials M  states M"
  by (auto simp: trivials_def mec_def trivial_le_iff)

text ‹Bottom MEC (BEMC) in @{term M}
definition bmec :: "'s mdpc  's mdpc  bool"
  where "bmec M φ  mec φ M  (sstates φ. actions φ s = actions M s)"

definition actions' :: "'s mdpc  's  's pmf set"
  where "actions' M s = (if s  states M then actions M s else {return_pmf s})"

lemma closed_mdpcD':
  "closed_mdpc M  s  states M  (Dactions' M s. set_pmf D)  states M"
  by (auto simp: actions'_def dest: closed_mdpcD)

locale Finite_MDP =
  fixes M :: "'s mdpc"
  assumes closed_M: "closed_mdpc M" and M_neq_bot: "M  bot"
    and actions_neq_empty_M: "s. s  states M  actions M s  {}"
    and finite_states_M: "finite M"
    and finite_actions_M: "s. finite (actions M s)"
begin

sublocale Finite_Markov_Decision_Process "actions' M" "states M"
proof
  show "actions' M s  {}" for s
    using actions_neq_empty_M by (auto simp: actions'_def )
  show "states M  {}" "finite M" "s. finite (actions' M s)"
    using M_neq_bot finite_states_M finite_actions_M by (auto simp: eq_bot_iff_states actions'_def)
  show "s  states M  (Dactions' M s. set_pmf D)  states M" for s
    using closed_M by (rule closed_mdpcD')
qed

lemma Finite_MDP_map_loop: "Finite_MDP (map_mdpc f M  loop s)"
proof
  show "closed_mdpc (map_mdpc f M  loop s)"
    by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_loop)
  show "finite (actions (map_mdpc f M  loop s) t)" for t
    by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
  show "finite (map_mdpc f M  loop s)"
    by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: loop_neq_bot states_map_mdpc actions_loop actions_map_mdpc dest: actions_neq_empty_M)

lemma Finite_MDP_map_fix_loop: "Finite_MDP (fix_loop s (map_mdpc f M))"
proof
  show "closed_mdpc (fix_loop s (map_mdpc f M))"
    by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_fix_loop)
  show "finite (actions (fix_loop s (map_mdpc f M)) t)" for t
    by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
  show "finite (fix_loop s (map_mdpc f M))"
    by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: fix_loop_neq_bot states_map_mdpc actions_map_mdpc dest: actions_neq_empty_M)

end

context
  fixes M :: "'s mdpc"
    and F :: "'s set"
  assumes M_neq_bot: "M  bot"
    and closed_M: "closed_mdpc M"
    and actions_neq_empty_M: "s. s  states M  actions M s  {}"
    and finite_states_M: "finite M"
    and finite_actions_M: "s. finite (actions M s)"
    and F_subset: "F  states M"
begin

lemma finite_F[simp]: "finite F"
  using F_subset finite_states_M by (auto dest: finite_subset)

interpretation M: Finite_MDP M
  proof qed fact+

interpretation M: Reachability_Problem "actions' M" "states M" "states M - F" F
  proof qed (insert F_subset, auto)

definition r :: "'s  's option"
  where "r s = (if s  F then None else Some s)"

lemma r_eq_None[simp]: "r s = None  s  F"
  by (simp add: r_def)

lemma r_eq_Some[simp]: "r s = Some t  (s  F  s = t)"
  by (simp add: r_def)

lemma r_in_Some_image: "r s  Some ` X  (s  F  s  X)"
  by (auto simp: r_def)

lemma r_inj: "s  F  t  F  r s = r t  s = t"
  by (auto simp: r_def)

lemma shows r_F: "s  F  r s = None" and r_nF: "s  F  r s = Some s"
  by auto

definition R :: "'s option mdpc"
  where "R = fix_loop None (map_mdpc r M)"

lemma closed_R: "closed_mdpc R"
  unfolding R_def by (intro closed_mdpc_map closed_M closed_mdpc_fix_loop)

lemma states_R[simp]: "states R = Some ` (states M - F)  {None}"
  by (auto simp add: R_def r_def[abs_def] states_map_mdpc)

lemma actions_R_None[simp]:
  "actions R None = {return_pmf None}"
  by (auto simp add: R_def)

lemma actions_R_Some[simp]:
  "actions R (Some s) = (if s  F then {} else map_pmf r ` actions M s)"
  by (auto simp add: R_def actions_map_mdpc split: if_splits intro!: imageI)

lemma mec_R_loop: "mec R (loop None)"
  unfolding R_def by (intro mec_fix_loop)

interpretation R: Finite_MDP R
  unfolding R_def by (rule M.Finite_MDP_map_fix_loop)

interpretation R: Reachability_Problem "actions' R" "states R" "{None}" "{}"
  proof qed auto

lemma F_not_trivial: "s  F  Some s  trivials R"
  by (auto simp: trivials_def mec_def trivial_le_iff)

primrec min_state :: "'s option  's + bool"
  where
    "min_state None = Inr True"
  | "min_state (Some s) = (if Some s  trivials R then Inl s else Inr False)"

lemma min_state_eq_Inl: "min_state s = Inl t  (Some t  trivials R  s = Some t)"
  by (cases s) auto

lemma min_state_eq_Inr: "min_state s = Inr b  (if b then s = None else s  None  s  trivials R)"
  by (cases s) auto

lemma map_min_state_R: "map_mdpc min_state R = fix_loop (Inr True) (map_mdpc (min_state  r) M)"
  unfolding R_def
  by (subst map_fix_loop)
     (auto simp: map_mdpc_compose min_state_eq_Inr eq_commute[of "Inr True"])

definition min_mdpc :: "('s + bool) mdpc"
  where "min_mdpc = fix_loop (Inr False) (map_mdpc min_state R)"

lemma states_min_mdpc: "states min_mdpc = {Inl t | t. Some t  trivials R}  {Inr True, Inr False}"
  using trivials_subset_states[of R] by (auto simp add: min_mdpc_def states_map_mdpc image_comp split: if_splits)

lemma actions_min_mdpc_Inl:
  "actions min_mdpc (Inl t) = (if Some t  trivials R then map_pmf (min_state  r) ` actions M t else {})"
proof -
  have eq: "min_state -` {Inl t} = (if Some t  trivials R then {Some t} else {})"
    by (auto simp: min_state_eq_Inl)
  show ?thesis using F_not_trivial[of t]
    by (simp add: min_mdpc_def actions_map_mdpc eq image_comp map_pmf_compose[symmetric])
qed

lemma actions_min_mdpc_Inr: "actions min_mdpc (Inr b) = {return_pmf (Inr b)}"
  by (simp add: min_mdpc_def map_min_state_R)

interpretation min: Finite_MDP min_mdpc
  unfolding min_mdpc_def by (rule R.Finite_MDP_map_fix_loop)

interpretation min: Reachability_Problem "actions' min_mdpc" "states min_mdpc" "states min_mdpc - {Inr True}" "{Inr True}"
  proof qed (auto simp: states_min_mdpc)

lemma M_n_eq_0_not_trivials:
  assumes "s  states M" "s  F" "Some s  trivials R"
  shows "M.n s = 0"
proof -
  have "Some s  states R"
    using assms by auto

  obtain φ where "mec R φ" "s  Some -` φ"
    using mec_exists'[OF ‹Some s  states R›] by auto
  then have action_φ: "Some t  φ  actions φ (Some t)  {}" for t
    using mec_ec[OF ‹mec R φ] ‹Some s  trivials R› sc_eq_trivial[of φ "Some t"]
    by (auto simp: ec_def trivials_def)

  have None_notin_states: "None  states φ"
    using mec_R_loop ‹mec R φ s  Some -` φ mec_unique[of R "loop None" φ]
    by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)

  from s  Some -` φ show "M.n s = 0"
  proof (rule M.n_eq_0_closed)
    show "Some -` states φ  states M" "Some -` states φ  F = {}"
      using mec_le[OF ‹mec R φ] by (auto simp: r_def le_mdpc_iff)
    fix s assume "s  Some -` φ"
    then have s: "s  states M" "s  F" "actions φ (Some s)  {}"
      using mec_le[OF ‹mec R φ] by (auto simp: le_mdpc_iff action_φ)
    then obtain D where D: "D  actions φ (Some s)"
      by auto
    then have "D  actions R (Some s)"
      using mec_le[OF ‹mec R φ, THEN actions_mono] s by (auto simp add: le_fun_def simp del: actions_R_Some)
    with s obtain D' where D_eq: "D = map_pmf r D'" and D': "D'  actions M s"
      by auto
    have "set_pmf D  states φ"
      using closed_mdpcD[OF _ D] mec_ec[OF ‹mec R φ] by (auto simp: ec_def)
    then have "set_pmf D = Some ` set_pmf D'"
      using closed_mdpcD[of φ, OF _ D  actions φ (Some s)] None_notin_states
        mec_ec[OF ‹mec R φ]
      unfolding D_eq by (auto intro!: image_cong simp: r_def ec_def)
    then show "xactions' M s. set_pmf x  Some -` states φ"
      using s  states M ‹set_pmf D  states φ D'
      by (intro bexI[of _ D']) (auto simp: actions'_def)
  qed
qed

lemma min_state_r_in_min_mdpc[simp]: "s  M  min_state (r s)  min_mdpc"
  by (auto simp add: states_min_mdpc min_state_eq_Inr min_state_eq_Inl r_def)

end

end